diff --git a/runGhcBWrap-core.cabal b/runGhcBWrap-core.cabal new file mode 100644 --- /dev/null +++ b/runGhcBWrap-core.cabal @@ -0,0 +1,38 @@ +--cabal-version: 3.10 +category: Control +maintainer: galen.sprout@gmail.com +cabal-version: >= 1.10 +name: runGhcBWrap-core +version: 0.1.0.0 +license: MIT +synopsis: + Build haskell executables +description: + Build haskell executables through types and IStr, with the ability to pass data back and forth via JSON and types from this package. +build-type: Simple + +library + hs-source-dirs: src + default-language: Haskell2010 + build-depends: IStr >= 0.1.0 && < 0.2 + , aeson >= 2.2.3 && < 2.3 + , base >= 4.20.2 && < 4.21 + , data-default >= 0.8.0 && < 0.9 + , filepath >= 1.5.4 && < 1.6 + , parsec >= 3.1.18 && < 3.2 + , random >= 1.3.1 && < 1.4 + , scrappy-core >= 0.1.0 && < 0.2 + , split >= 0.2.5 && < 0.3 + , text >= 2.1.3 && < 2.2 + exposed-modules: + RunGhc.UserInput + RunGhc.TrivialBuilders + RunGhc.MakeTest + RunGhc.MakeTest.TypeSig + RunGhc.MakeTest.HKTs + RunGhc.MakeTest.FFI + RunGhc.MakeExe + RunGhc.Executable + RunGhc.Locate + RunGhc.LocatedModule + RunGhc.SystemModule diff --git a/src/RunGhc/Executable.hs b/src/RunGhc/Executable.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/Executable.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module RunGhc.Executable where + +import RunGhc.SystemModule +import RunGhc.LocatedModule +import RunGhc.Locate +import System.FilePath +import Data.Aeson +import GHC.Generics +import qualified Data.Text as T +import qualified Data.Text.IO as T +-- NOTE: we are going to need functionality to get from github +-- or at least from .tar.gz + +data Executable = Executable + { _main :: LocatedModule + , _library :: [LocatedModule] + } deriving Generic +instance ToJSON Executable +instance FromJSON Executable + +data ExecutableWithDeps = ExecutableWithDeps + { _exe :: Executable + , _packages :: [PackageName] + } + +data ExecutableWithDepsWithCommand = ExecutableWithDepsWithCommand + { _exeWithDeps :: ExecutableWithDeps + , _commandWithArgs :: [T.Text] -- default would be runghc + } + +newtype PackageName = PackageName { getPackageName :: T.Text } + +getTargetModule :: Executable -> [PathSegment] +getTargetModule = getPathSegments . _main + +getTargetModulePath :: T.Text -> Executable -> FilePath +getTargetModulePath fext = pathSegsToPath fext . getTargetModule + +-- Perhaps Executable becomes own module +writeExecutable :: FilePath -> Executable -> IO () +writeExecutable baseDir exe = + writeLocatedFiles baseDir $ _main exe : _library exe + +writeLocatedFiles :: FilePath -> [LocatedModule] -> IO () +writeLocatedFiles baseDir modules = do + mapM_ (writeLocatedFile baseDir) modules + where + fileExt = ".hs" + + writeLocatedFile baseDir_ = \case + FromLocatedScript (LocatedScript pathSegs (Script script)) -> + T.writeFile (baseDir_ pathSegsToPath fileExt pathSegs) script + FromSystemModule pathSegs systemModule -> do + T.writeFile (baseDir pathSegsToPath fileExt pathSegs) $ getScript $ systemModuleToScript pathSegs systemModule + -- So that we can write to file + makeModuleDeclaration :: [PathSegment] -> Script + makeModuleDeclaration pathSegs = Script ("module " <> (pathSegsToModuleName pathSegs) <> " where\n") + + mkImport :: Import -> T.Text + mkImport imp = case _import_qualifiedName imp of + Nothing -> "import " <> pathSegsToModuleName (_import_pathSeg imp) + Just qName -> "import qualified " <> pathSegsToModuleName (_import_pathSeg imp) <> " as " <> qName + makeImports (Imports importList) = Script $ T.unlines $ mkImport <$> importList + + fromExpressions :: Expressions -> Script + fromExpressions = Script . getExpressions + + makeExtensions (Extensions (exts)) = Script $ + "{-# LANGUAGE" <> T.intercalate ", " exts <> " #-}" + + systemModuleToScript :: [PathSegment] -> SystemModule -> Script + systemModuleToScript pathSegs = \case + ExpressionsOnly (Expressions rawSource) -> + makeModuleDeclaration pathSegs -- Script ("module " <> T.pack (pathSegsToModuleName pathSegs) <> " where\n") + <> Script rawSource + ExpressionsImportsOnly imports (Expressions rawSource) -> + makeModuleDeclaration pathSegs + <> makeImports imports + <> Script rawSource + ExpressionsImportsExtensionsOnly extensions imports (Expressions rawSource) -> + makeExtensions extensions + <> makeModuleDeclaration pathSegs + <> makeImports imports + <> Script rawSource + +-- attachLibraryToUserModule :: LocatedUserModule -> Located-> [LocatedModule] -> Executable +-- attachLibraryToUserModule +addUserLibraryToExecutable :: LocatedUserModule -> Executable -> Executable +addUserLibraryToExecutable (LocatedUserModule loc) exe = Executable (addImports (Imports [toSimpleImport $ getPathSegments loc]) (_main exe)) [loc] + +addSystemLibraryToExecutable :: LocatedTestModule -> Executable -> Executable +addSystemLibraryToExecutable (LocatedTestModule locs) exe = Executable (_main exe) $ locs : (_library exe) + +addSystemLibrariesToExecutable :: [LocatedModule] -> Executable -> Executable +addSystemLibrariesToExecutable locs exe = Executable (_main exe) $ locs <> (_library exe) + diff --git a/src/RunGhc/Locate.hs b/src/RunGhc/Locate.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/Locate.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module RunGhc.Locate where + +import Data.Aeson +import GHC.Generics +import System.FilePath +import qualified Data.List.Split as List +import qualified Data.Text as T + +toSimpleImport :: [PathSegment] -> Import +toSimpleImport = Import Nothing + +toQualifiedImport :: T.Text -> [PathSegment] -> Import +toQualifiedImport qname segs = Import (Just qname) segs + +newtype PathSegment = PathSegment { getPathSegment :: T.Text } + deriving (Show, Generic) +instance ToJSON PathSegment +instance FromJSON PathSegment +data Import = Import + { _import_qualifiedName :: Maybe T.Text + , _import_pathSeg :: [PathSegment] + } deriving (Show, Generic) +instance ToJSON Import +instance FromJSON Import + +newtype Imports = Imports { getImports :: [Import] } deriving (Show, Generic) +instance FromJSON Imports +instance ToJSON Imports +instance Semigroup Imports where + Imports a <> Imports b = Imports $ a <> b +instance Monoid Imports where + mempty = Imports mempty + +type FileExt = T.Text +pathSegsToPath :: FileExt -> [PathSegment] -> FilePath +pathSegsToPath fileExt ((PathSegment p):[]) = T.unpack $ p <> fileExt +pathSegsToPath fE ((PathSegment p):ps) = T.unpack p pathSegsToPath fE ps + +pathSegsFromFilePath :: FilePath -> [PathSegment] +pathSegsFromFilePath = fmap (PathSegment . T.pack) . List.splitOn "/" + +pathSegsToModuleName :: [PathSegment] -> T.Text +pathSegsToModuleName ((PathSegment p):[]) = p +pathSegsToModuleName ((PathSegment p):ps) = p <> "." <> pathSegsToModuleName ps + +-- HeadlessScript ==> LocatedModule +makeSourcePath :: FilePath -> [PathSegment] -> FilePath +makeSourcePath baseDir segs = + let segs_ = T.intercalate "/" $ getPathSegment <$> segs + in + baseDir (T.unpack segs_) + +showImportLine :: Import -> T.Text +showImportLine imp = case _import_qualifiedName imp of + Nothing -> + "import " <> pathSegsToModuleName (_import_pathSeg imp) <> "" + Just qName -> + "import qualified " + <> pathSegsToModuleName (_import_pathSeg imp) + <> " as " + <> qName + <> "" diff --git a/src/RunGhc/LocatedModule.hs b/src/RunGhc/LocatedModule.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/LocatedModule.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module RunGhc.LocatedModule where + +import RunGhc.SystemModule +import RunGhc.Locate +import System.FilePath +import Data.Aeson +import GHC.Generics +import qualified Data.List.Split as List +import qualified Data.List as List +import qualified Data.Text as T +import qualified Data.Text.IO as T + +localImport :: LocatedModule -> Import +localImport mod = Import Nothing (getPathSegments mod) + +localQualifiedImport :: T.Text -> LocatedModule -> Import +localQualifiedImport qname mod = Import (Just qname) (getPathSegments mod) + +-- This is an interesting case +-- because the result can absolutely be wrong +-- But we want to be careful where we allow that failure +-- sometimes we even want that failure! +-- +-- One case we never want this failure is with a TestModule we make. +-- User modules however can be designed to fail this way if user +-- has been allowed to make a mistake and has +class Locatable a where + locate :: [PathSegment] -> a -> LocatedModule +-- | These instances describe the +-- boring logistical differences between +-- +-- 1) A full script given +-- 2) Only a function given +-- 3) A module we create fully +-- +-- While broad, this is the last script of including +-- some Haskell symbols in our end executable +-- +-- The utility of this is that often, linking/locating is the last step we +-- want to think of + +instance Locatable Script where + locate pathSeg script = + FromLocatedScript $ LocatedScript pathSeg script +instance Locatable SystemModule where + locate pathSeg sysMod = + FromSystemModule pathSeg sysMod +instance Locatable Expressions where + locate pathSeg expressions = + FromSystemModule pathSeg $ ExpressionsOnly expressions + +instance SemigroupModule LocatedModule where + addImports imports = \case + loc@(FromLocatedScript _) -> loc + sys@(FromSystemModule _ _) -> addImports imports sys + addExtensions extensions = \case + loc@(FromLocatedScript _) -> loc + sys@(FromSystemModule _ _) -> addExtensions extensions sys + addFuncsDataDecls script = \case + loc@(FromLocatedScript _) -> loc + sys@(FromSystemModule _ _) -> addFuncsDataDecls script sys + + +getPathSegments :: LocatedModule -> [PathSegment] +getPathSegments = \case + FromLocatedScript (LocatedScript pathSegs _) -> pathSegs + FromSystemModule pathSegs _ -> pathSegs + +-- Is there value in this construct? +data DependentLocatedModule = DependentLocatedModule + { _locatedModule :: LocatedModule + , _deps :: [[PathSegment]] + } + +data LocatedModule + = FromLocatedScript LocatedScript + -- ^ Nothing to process to create+write Module + -- but we probably still need to make it as a lib and link it + -- with expected targets if it is a user Module + | FromSystemModule [PathSegment] SystemModule + deriving Generic + -- ^ Builder descriptions to create+write Module +instance ToJSON LocatedModule +instance FromJSON LocatedModule + + +-- | Witness that this script has module written in +data LocatedScript = LocatedScript [PathSegment] Script deriving Generic +instance ToJSON LocatedScript +instance FromJSON LocatedScript + +newtype LocatedUserModule = LocatedUserModule + { getLocatedUserModule :: LocatedModule } +newtype LocatedMainModule = LocatedMainModule + { getLocatedMainModule :: LocatedModule } +newtype LocatedTestModule = LocatedTestModule + { getLocatedTestModule :: LocatedModule } + + +newtype Script = Script { getScript :: T.Text } deriving (Show, Generic) +instance ToJSON Script +instance FromJSON Script +instance Semigroup Script where + Script a <> Script b = Script $ a <> b +instance Monoid Script where + mempty = Script mempty + +newtype Symbol = Symbol { getSymbol :: T.Text } -- should never get a show instance diff --git a/src/RunGhc/MakeExe.hs b/src/RunGhc/MakeExe.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/MakeExe.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module RunGhc.MakeExe where + +import RunGhc.Locate +import RunGhc.LocatedModule +import RunGhc.Executable +import RunGhc.SystemModule + +import Text.IStr +import qualified Data.List as List +import qualified Data.Text as T + +-- simple tests that are monoidal and evaluate the validity of user input + +-- PLAN +-- build user module somehow + -- `tryHandleUserInputExpressionsOnly` OR `asLibWithMain` +-- build test script with reference to user module + -- `mkTestScriptBracketed` + -- + -- OR any other way :: (T.Text -> Executable) + -- but more specifically (T.Text -> (LocatedUserModule, LocatedTestModule)) +-- we locate our test script at Main +-- we morph into executable + + +-- NOTE: +-- (LocatedUserModule, LocatedTestModule) +-- is isomorphic to Executable +toExe :: LocatedUserModule -> LocatedTestModule -> Executable +toExe (LocatedUserModule locUser) (LocatedTestModule locTest) = + Executable + { _main = locTest + , _library = [locUser] + } + +defaultHeadMainModule :: (Imports, Extensions) +defaultHeadMainModule = + ( (Imports + [ Import Nothing $ PathSegment <$> ["Data", "Text"] + , Import Nothing $ PathSegment <$> ["Data", "Aeson"] + ]) + , (Extensions + ["OverloadedStrings" + ]) + ) + +toSingleModuleExe :: LocatedModule -> Executable +toSingleModuleExe loc = Executable loc [] +-- Cuter way to do it +-- The symbol represents a name the script must provide +mkTestScriptBracketed + :: Qualifiable symbolic + => LocatedUserModule + -> symbolic + -> Imports + -> Extensions + -> (Symbol -> Expressions) -- before + -> (Symbol -> Expressions) -- after + -> (Symbol -> symbolic -> Expressions) + -- ^ make test function + -- first Symbol is just to define main properly + -> SystemModule --LocatedTestModule +mkTestScriptBracketed (userModule) symbols imports extensions before after mkTest = + -- We can also easily call Locate on this.. at any point + ExpressionsImportsExtensionsOnly + extensions + imports + $ scriptMkMain + <> (before pre) + <> (mkTest inner symbols) -- (if hasMain then ")--(mkTest inner) + <> (after post) + where + pre = Symbol "pre" + inner = Symbol "inner" + post = Symbol "post" + scriptMkMain = Expressions $ T.pack x + x :: String + x = [istr| +main :: IO () +main = #{getSymbol pre} >> #{getSymbol inner} >> #{getSymbol post} +|] + + +-- makeTestScript "f" withF +makeTestScript :: [PathSegment] -> FunctionName -> (FunctionName -> Expressions) -> LocatedModule +makeTestScript pathLoc fname withF = FromSystemModule pathLoc $ ExpressionsOnly $ withF fname + +type QualifiedName = T.Text +makeTestScriptWithImportsExtensions + :: Qualifiable a + => [PathSegment] + -> Imports + -> Extensions + -> a -- FunctionName for instance + -> LocatedModule -- The user module + -> (a -> Expressions) + -> LocatedModule +makeTestScriptWithImportsExtensions pathLoc imps exts symbols userModule withF = + addExtensions exts + $ addImports (Imports [localQualifiedImport "UserModule" userModule]) + $ addImports imps $ FromSystemModule pathLoc $ ExpressionsOnly $ withF (qualify "UserModule" symbols) + + + +-- eg +mkMainWithDefaultHead + :: Qualifiable symbols + => LocatedModule + -- ^ User module we interface with + -> symbols + -- ^ Symbols assumed to exist in UserModule + -> (symbols -> Expressions) + -- ^ Make Test + -> LocatedModule + -- ^ Resulting module +mkMainWithDefaultHead userModule symbols mkExpr = + makeTestScriptWithImportsExtensions + [PathSegment "Main"] + (fst $ defaultHeadMainModule) + (snd $ defaultHeadMainModule) + symbols + userModule + mkExpr + +simpleMainModule :: FunctionName -> LocatedUserModule -> LocatedTestModule +simpleMainModule fname (LocatedUserModule userMod) = + simpleExeFromFunctionNameAsLib fname userMod + --mkMainWithDefaultHead userModule symbols mkExpr + +simpleExeFromFunctionNameAsLib :: FunctionName -> LocatedModule -> LocatedTestModule +simpleExeFromFunctionNameAsLib fname userMod = LocatedTestModule $ mkMainWithDefaultHead userMod (Symbol fname) $ \(Symbol func_) -> + Expressions . T.pack $ [istr| main = #{func_} |] + +-- This has a default module head as well as the import from UserModule +simpleExeFromUserMainAsLib :: LocatedModule -> LocatedTestModule +simpleExeFromUserMainAsLib userMod = simpleExeFromFunctionNameAsLib "main" userMod + +-- SAME AS ABOVE +-- mkUserExecutableAsLibrary :: LocatedUserModule -> Executable +-- mkUserExecutableAsLibrary (LocatedUserModule loc) = Executable (mod qname_) [loc] +-- where +-- qname_ = "UserModule" +-- importLine = showImportLine $ localQualifiedImport qname_ loc --Import Nothing [getPathSegments loc +-- mod qname = FromLocatedScript $ LocatedScript [PathSegment "Main"] $ Script . T.pack $ [istr| +-- module Main where +-- #{importLine} +-- main = #{qname}.main +-- |] + + + +mkMainExeWithDefaultHead + :: Qualifiable symbols + => LocatedModule + -- ^ User module we interface with + -> symbols + -- ^ Symbols assumed to exist in UserModule + -> (symbols -> Expressions) + -- ^ Make Test + -> Executable -- LocatedModule + -- ^ Resulting module +mkMainExeWithDefaultHead userModule symbols mkExpr = + Executable + { _main = mkMainWithDefaultHead userModule symbols mkExpr + , _library = [userModule] + } + + +-- | callFunction "f" (LocatedModule{..}) +-- where f is implicitly :: IO () +callFunction' + :: FunctionName + -> LocatedUserModule + -> (FunctionName -> Expressions) + -> Executable +callFunction' fname (LocatedUserModule loc) mkExpr = Executable mod [loc] + where + qname = "UserModule" + importLine = showImportLine $ localQualifiedImport qname loc --Import Nothing [getPathSegments loc + toScript = Script . getExpressions + mod = FromLocatedScript $ LocatedScript [PathSegment "Main"] $ toScript $ mkExpr fname --Script + + +class Qualifiable a where + qualify :: T.Text -> a -> a +instance Qualifiable Symbol where + qualify pre (Symbol sname) = Symbol $ pre <> "." <> sname +instance Qualifiable (Symbol, Symbol) where + qualify pre (s1,s2) = (qualify pre s1, qualify pre s2) +instance Qualifiable (Symbol, Symbol, Symbol) where + qualify pre (s1,s2,s3) = (qualify pre s1, qualify pre s2, qualify pre s3) +instance Qualifiable (Symbol, Symbol, Symbol, Symbol) where + qualify pre (s1,s2,s3, s4) = (qualify pre s1, qualify pre s2, qualify pre s3, qualify pre s4) +instance Qualifiable (Symbol, Symbol, Symbol, Symbol, Symbol) where + qualify pre (s1,s2,s3,s4,s5) = (qualify pre s1, qualify pre s2, qualify pre s3, qualify pre s4, qualify pre s5) +instance Qualifiable (Symbol, Symbol, Symbol, Symbol, Symbol, Symbol) where + qualify pre (s1,s2,s3,s4,s5,s6) = (qualify pre s1, qualify pre s2, qualify pre s3, qualify pre s4, qualify pre s5, qualify pre s6) +instance Qualifiable (Symbol, Symbol, Symbol, Symbol, Symbol, Symbol, Symbol) where + qualify pre (s1,s2,s3,s4,s5,s6,s7) = (qualify pre s1, qualify pre s2, qualify pre s3, qualify pre s4, qualify pre s5, qualify pre s6, qualify pre s7) +instance Qualifiable (Symbol, Symbol, Symbol, Symbol, Symbol, Symbol, Symbol, Symbol) where + qualify pre (s1,s2,s3,s4,s5,s6,s7,s8) = (qualify pre s1, qualify pre s2, qualify pre s3, qualify pre s4, qualify pre s5, qualify pre s6, qualify pre s7, qualify pre s8) +instance Qualifiable (Symbol, Symbol, Symbol, Symbol, Symbol, Symbol, Symbol, Symbol, Symbol) where + qualify pre (s1,s2,s3,s4,s5,s6,s7,s8,s9) = + (qualify pre s1, qualify pre s2, qualify pre s3, qualify pre s4, qualify pre s5, qualify pre s6, qualify pre s7, qualify pre s8, qualify pre s9) + + + +-- NOTE: for generating an infinite stream, since we still do (Take n) +-- we can always write this to input.json (and maybe other places) so that +-- the user can do whatever they want +-- +-- Could also be that we have inputs/1.json , inputs/2.json .. inputs/n.json + + +type TypeName = T.Text +-- type FunctionName = T.Text +type DataConstructorName = T.Text +-- +newtype Hash = Hash T.Text +data Function_ = Function_ + { _function_name :: T.Text + , _function_typeSig :: TypeSig + } +newtype ModuleName = ModuleName T.Text +-- newtype Imports = Imports [T.Text] +newtype TypeSig = TypeSig T.Text + +data SumTypeInfo = SumTypeInfo + { _sumTypeInfo_typeName :: T.Text + , _sumTypeInfo_kind :: Int + , _sumTypeInfo_expressions :: [SumTypeCase] + } + +data SumTypeCase = SumTypeCase + { _sumTypeCase_name :: T.Text + , _sumTypeCase_argsCount :: Int + } + +mkSumTypePattern :: SumTypeCase -> T.Text +mkSumTypePattern (SumTypeCase name argsCount) = + T.pack $ '\t' : (T.unpack $ name <> " " <> (T.pack $ List.intersperse ' ' $ take argsCount $ repeat '_'))---['a' .. 'z'])) + +existsSumType :: SumTypeInfo -> Script +existsSumType sumInfo = + let + sumTypeName :: T.Text + sumTypeName = _sumTypeInfo_typeName sumInfo + + fakeTypeArgs :: [Char] + fakeTypeArgs = List.intersperse ' ' $ take (_sumTypeInfo_kind sumInfo) ['a' .. 'z'] + typeInTypeSig = sumTypeName <> " " <> T.pack fakeTypeArgs + patterns = fmap mkSumTypePattern $ _sumTypeInfo_expressions sumInfo + + in Script $ (T.pack $ [istr| +ace_required_CaseStatement_f#{sumTypeName} :: #{typeInTypeSig} -> Int +ace_required_CaseStatement_f#{sumTypeName} = \\case +|]) <> (T.unlines + $ (\(list_) -> list_ <> ["\t_ -> -1"]) + $ fmap (\(num, pattern_) -> (pattern_) <> " -> " <> (T.pack $ show @Int num) ) + $ zip + [1..] + $ + patterns + ) + +existsType' :: Hash -> TypeName -> Script +existsType' (Hash h) t = Script $ T.pack [istr| +ace_requiredType_T_#{h} :: #{t} +ace_requiredType_T_#{h} = undefined +|] + +data FunctionInfo = FunctionInfo + { _functionInfo_name :: T.Text + , _functionInfo_typeSig :: T.Text + } + +-- Test both +existsFunction'' :: FunctionInfo -> Script +existsFunction'' fInfo = + let + fName = _functionInfo_name fInfo + tSig = _functionInfo_typeSig fInfo + + in Script $ T.pack + [istr| +ace_requiredFunctionInfo_F_#{fName} :: #{tSig} +ace_requiredFunctionInfo_F_#{fName} = #{fName} + +ace_requiredFunctionInfo_F_#{fName}_Copy = ace_requiredFunctionInfo_F_#{fName} + |] + +existsFunctionName' :: FunctionName -> Script +existsFunctionName' fName = Script $ T.pack [istr| +ace_requiredFunction_F_#{fName} = #{fName} +|] + +data ClassInfo = ClassInfo + { _clsInfo_className :: T.Text + , _clsInfo_functionHeads :: [(FunctionName, TypeSig)] + } + +-- Should type sig be a little more specific? +-- data TypeSig' = TypeSig' +-- { _typeSig_forall :: Maybe (NonEmpty [T.Text]) +-- , _typeSig_classesUsed :: Maybe (NonEmpty [T.Text]) +-- , _typeSig_inputTypes :: Maybe (NonEmpty [T.Text]) +-- , _typeSig_resultType :: T.Text +-- } + +-- Where type sig is a singular line +-- class RenderTypeSig a where +-- renderTypeSig :: a -> TypeSig +-- instance RenderTypeSig TypeSig where +-- renderTypeSig = id +-- instance RenderTypeSign TypeSig' where +-- renderTypeSig tSig' = +-- let +-- forall = +-- maybe +-- "" +-- (\t -> ) +-- (_typeSig_forall tSig') + +existsClass :: ClassInfo -> Script +existsClass clsInfo = + let + className = _clsInfo_className clsInfo + + applyF :: (T.Text, TypeSig) {-function heads-} -> Script + applyF (name, TypeSig typeSig) = Script $ T.pack [istr| +ace_requiredClass_Class_#{className} :: #{typeSig} +ace_requiredClass_Class_#{className} = #{name} +|] + in + mconcat $ applyF <$> _clsInfo_functionHeads clsInfo + +existsDataConstructor :: DataConstructorName -> Script +existsDataConstructor dName = existsFunctionName' dName + +existsDataConstructors :: [DataConstructorName] -> Script +existsDataConstructors dNames = existsFunctionNames dNames + +existsFunctionNames :: [FunctionName] -> Script +existsFunctionNames [] = Script "" +existsFunctionNames (dName:xs) = + existsFunctionName' dName <> existsFunctionNames xs + +-- -- -- Take beginner friendly templates and make them something we can export +-- userPureFunctionToModule :: ModuleName -> Imports -> Function_ -> Script +-- userPureFunctionToModule (ModuleName mdlName) (Imports imports) func = +-- Script $ +-- "module " <> mdlName <> " where " +-- <> T.unlines imports +-- <> T.pack +-- [istr| +-- #{script} + +-- main = +-- |] + +-- -- -- Take beginner friendly templates and make them something we can export +-- userImpureFunctionToModule :: ModuleName -> Imports -> Function_ -> Script +-- userImpureFunctionToModule (ModuleName mdlName) (Imports imports) func = +-- Script $ +-- "module " <> mdlName <> " where " +-- <> T.unlines imports +-- <> T.pack +-- [istr| +-- #{script} +-- |] + + +-- mk :: FunctionName -> FunctionName +-- f = myFunctionName + +-- OR +-- mk :: FunctionalCase -> IO () + +newtype Tests = Tests T.Text + diff --git a/src/RunGhc/MakeTest.hs b/src/RunGhc/MakeTest.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/MakeTest.hs @@ -0,0 +1,1144 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} + +module RunGhc.MakeTest where + +import RunGhc.Locate +import RunGhc.LocatedModule +import RunGhc.SystemModule +import RunGhc.Executable +import RunGhc.MakeExe +import RunGhc.UserInput +import RunGhc.MakeTest.TypeSig +import RunGhc.MakeTest.HKTs +import RunGhc.MakeTest.FFI + +import GHC.Generics +import Text.IStr +import Control.Monad (replicateM) +import Data.Typeable +import Data.Aeson +import Data.Maybe +import qualified Data.Text as T +import Data.Default +import Data.Bifunctor +import Data.Text (Text, pack) +import System.Random (randomRIO) +import System.Exit +import Data.Char (toUpper) + +-- new idea : standardized Main.hs that runs 2 sets of symbols + +-- Could also do these script builders by Arity + + +--x = compareFunc "f" mkF + +--mkExample fname = + +-- For modeling user-input +data SourceCode = SourceCode + { _sourceCode_code :: T.Text + , _sourceCode_target :: FunctionName + } deriving Generic +instance FromJSON SourceCode +instance ToJSON SourceCode + +-- The scope of our computation the user can see +data CodeChallengeResult = CodeChallengeResult + { _ccrRunGhc_exitCode :: ExitCode + , _ccrRunGhc_stderr :: [String] + , _ccrRunGhc_tests :: [Bool] + } deriving Generic +instance FromJSON CodeChallengeResult +instance ToJSON CodeChallengeResult + +class Reduce a where + reduce :: a -> [Bool] + +instance Reduce CodeChallengeResult where + reduce = _ccrRunGhc_tests + +instance Reduce TestSolutionResult where + reduce tsol = fmap _success $ _testSolRunGhc_tests tsol + +-- The scope of our computation the user can see +data TestSolutionResult = TestSolutionResult + { _testSolRunGhc_exitCode :: ExitCode + , _testSolRunGhc_stderr :: [String] + , _testSolRunGhc_tests :: [TryCodeResult T.Text T.Text] + } deriving Generic +instance FromJSON TestSolutionResult +instance ToJSON TestSolutionResult + +-- A set of functions +data TypeInfo a b = TypeInfo + { _typesIn :: a + , _typeOut :: b + } +type T a = Proxy a +type_ :: T a +type_ = Proxy + +-- A neat hack to pass back the result like a typed-ffi +-- This is because we can import this in both the executable +-- passed to runghcand also import in the program which +-- calls runghc. +data TryCodeResult a b = TryCodeResult + { _input :: a -- TODO: better typing + , _output :: b -- TODO: better typing + , _expectedOutput :: b + , _success :: Bool + } deriving Generic + +instance Functor (TryCodeResult a) where + fmap f tryCodeResult = TryCodeResult + (_input tryCodeResult) + (f $ _output tryCodeResult) + (f $ _expectedOutput tryCodeResult) + (_success tryCodeResult) + +instance Bifunctor TryCodeResult where + bimap f g (TryCodeResult inp out expected success) = + TryCodeResult (f inp) (g out) (g expected) success + +instance (ToJSON a, ToJSON b) => ToJSON (TryCodeResult a b) +instance (FromJSON a, FromJSON b) => FromJSON (TryCodeResult a b) + +toCompareExe + :: LocatedUserModule -- User + -> LocatedTestModule -- System: Compare Against + -> LocatedTestModule -- Run Compare + -> Executable +toCompareExe (LocatedUserModule locUser) (LocatedTestModule locTestLib) (LocatedTestModule locTestMain) = + Executable + { _main = locTestMain + , _library = [locUser, locTestLib] + } + +-- There's no core reason we need to have the names be the same +-- +-- Also the only name we ever need to actually know (prior to runtime generation of the exe) +-- is the compilation target of the user's module +-- +-- There is truly no issue with randomly generating names. This will also help us to +-- enforce that the user just cannot ever get the references #{moduleName}.#{testFunction} or #{moduleName}.#{testData} +-- and in fact, we don't even know! only the compareFunc will for a sec! + +-- A script definition that defers picking names until later, this is why it contains a function +newtype NoNameScript = NoNameScript + { getNoNameScript + :: ModuleName {-random name-} + -> FunctionName {-random name-} + -> VarName {-random name-} + -> Script + -- ^ Should we instead make this Locatable a => a ? + } + +type VarName = T.Text + +-- A script definition that defers picking names until later, this is why it contains a function +newtype TypedNoNameScript inputSlot outputSlot = TypedNoNameScript + { getTypedNoNameScript + :: ModuleName {-random name-} + -> FunctionName {-random name-} + -> VarName{-random name-} + -> TypeInfo (T inputSlot) (T outputSlot) + -> Script + -- ^ Should we instead make this Locatable a => a ? + } + +data Purity = Pure | Impure + +--- monadic MAKE +--- change: use compareFuncHKT instead of compareFuncTyped -> set to False +compareGenArityT1 :: Purity -> TypedNoNameScript a b -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT1 purity = compareFuncHKT (lift purity . lambdaT1) + +compareGenArityT2 :: Purity -> TypedNoNameScript (a, b) c -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT2 purity = compareFuncHKT (lift purity . lambdaT2) + +compareGenArityT3 :: Purity -> TypedNoNameScript (a, b, c) d -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT3 purity = compareFuncHKT (lift purity . lambdaT3) + +compareGenArityT4 :: Purity -> TypedNoNameScript (a, b, c, d) e -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT4 purity = compareFuncHKT (lift purity . lambdaT4) + +compareGenArityT5 :: Purity -> TypedNoNameScript (a, b, c, d, e) f -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT5 purity = compareFuncHKT (lift purity . lambdaT5) + +compareGenArityT6 :: Purity -> TypedNoNameScript (a, b, c, d, e, f) g -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT6 purity = compareFuncHKT (lift purity . lambdaT6) + +compareGenArityT7 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g) h -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT7 purity = compareFuncHKT (lift purity . lambdaT7) + +compareGenArityT8 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h) i -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT8 purity = compareFuncHKT (lift purity . lambdaT8) + +compareGenArityT9 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i) j -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT9 purity = compareFuncHKT (lift purity . lambdaT9) + +compareGenArityT10 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j) k -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT10 purity = compareFuncHKT (lift purity . lambdaT10) + +compareGenArityT11 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k) l -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT11 purity = compareFuncHKT (lift purity . lambdaT11) + +compareGenArityT12 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l) m -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT12 purity = compareFuncHKT (lift purity . lambdaT12) + +compareGenArityT13 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m) n -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT13 purity = compareFuncHKT (lift purity . lambdaT13) + +compareGenArityT14 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n) o -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT14 purity = compareFuncHKT (lift purity . lambdaT14) + +compareGenArityT15 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) p -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT15 purity = compareFuncHKT (lift purity . lambdaT15) + +compareGenArityT16 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) q -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT16 purity = compareFuncHKT (lift purity . lambdaT16) + +compareGenArityT17 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) r -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT17 purity = compareFuncHKT (lift purity . lambdaT17) + +compareGenArityT18 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) s -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT18 purity = compareFuncHKT (lift purity . lambdaT18) + +compareGenArityT19 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) t -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT19 purity = compareFuncHKT (lift purity . lambdaT19) + +compareGenArityT20 :: Purity -> TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) u -> SourceCode -> IO (Either T.Text Executable) +compareGenArityT20 purity = compareFuncHKT (lift purity . lambdaT20) + + + +-- Is there a better way to say "This is from IO a but we know that a will be printed and decoded as FromJSON a +-- So all we need to do here is communicate what b is so that FromJSON works +-- and as i understand if we dont handle this properly then it will +-- likely error with "No instance for FromJSON (IO b)" +handleMonadicOutputType :: TypedNoNameScript a (m b) -> TypedNoNameScript a b +handleMonadicOutputType (TypedNoNameScript f) = TypedNoNameScript $ + \moduleName funcName varName (TypeInfo inputProxy outputProxy) -> + -- We need to construct a TypeInfo with (m b) as output + -- outputProxy :: Proxy b + -- We need :: Proxy (m b) + -- But we can't construct that from just Proxy b without knowing m + f moduleName funcName varName (TypeInfo inputProxy (liftProxy outputProxy)) + where + -- This doesn't work because we don't know what m is! + liftProxy :: Proxy b -> Proxy (m b) + liftProxy _ = Proxy + +---- Shortforms +compareMonadicArityT1 :: TypedNoNameScript a (m b) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT1 nnScript srcCode = compareGenArityT1 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT2 :: TypedNoNameScript (a, b) (m c) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT2 nnScript srcCode = compareGenArityT2 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT3 :: TypedNoNameScript (a, b, c) (m d) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT3 nnScript srcCode = compareGenArityT3 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT4 :: TypedNoNameScript (a, b, c, d) (m e) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT4 nnScript srcCode = compareGenArityT4 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT5 :: TypedNoNameScript (a, b, c, d, e) (m f) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT5 nnScript srcCode = compareGenArityT5 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT6 :: TypedNoNameScript (a, b, c, d, e, f) (m g) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT6 nnScript srcCode = compareGenArityT6 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT7 :: TypedNoNameScript (a, b, c, d, e, f, g) (m h) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT7 nnScript srcCode = compareGenArityT7 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT8 :: TypedNoNameScript (a, b, c, d, e, f, g, h) (m i) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT8 nnScript srcCode = compareGenArityT8 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT9 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i) (m j) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT9 nnScript srcCode = compareGenArityT9 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT10 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j) (m k) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT10 nnScript srcCode = compareGenArityT10 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT11 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k) (m l) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT11 nnScript srcCode = compareGenArityT11 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT12 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l) (m m1) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT12 nnScript srcCode = compareGenArityT12 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT13 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m1) (m n) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT13 nnScript srcCode = compareGenArityT13 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT14 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m1, n) (m o) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT14 nnScript srcCode = compareGenArityT14 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT15 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m1, n, o) (m p) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT15 nnScript srcCode = compareGenArityT15 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT16 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m1, n, o, p) (m q) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT16 nnScript srcCode = compareGenArityT16 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT17 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m1, n, o, p, q) (m r) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT17 nnScript srcCode = compareGenArityT17 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT18 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m1, n, o, p, q, r) (m s) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT18 nnScript srcCode = compareGenArityT18 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT19 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m1, n, o, p, q, r, s) (m t) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT19 nnScript srcCode = compareGenArityT19 Impure (handleMonadicOutputType nnScript) srcCode + +compareMonadicArityT20 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m1, n, o, p, q, r, s, t) (m u) -> SourceCode -> IO (Either T.Text Executable) +compareMonadicArityT20 nnScript srcCode = compareGenArityT20 Impure (handleMonadicOutputType nnScript) srcCode + + +comparePureArityT1 :: TypedNoNameScript a b -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT1 = compareGenArityT1 Pure + +comparePureArityT2 :: TypedNoNameScript (a, b) c -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT2 = compareGenArityT2 Pure + +comparePureArityT3 :: TypedNoNameScript (a, b, c) d -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT3 = compareGenArityT3 Pure + +comparePureArityT4 :: TypedNoNameScript (a, b, c, d) e -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT4 = compareGenArityT4 Pure + +comparePureArityT5 :: TypedNoNameScript (a, b, c, d, e) f -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT5 = compareGenArityT5 Pure + +comparePureArityT6 :: TypedNoNameScript (a, b, c, d, e, f) g -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT6 = compareGenArityT6 Pure + +comparePureArityT7 :: TypedNoNameScript (a, b, c, d, e, f, g) h -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT7 = compareGenArityT7 Pure + +comparePureArityT8 :: TypedNoNameScript (a, b, c, d, e, f, g, h) i -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT8 = compareGenArityT8 Pure + +comparePureArityT9 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i) j -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT9 = compareGenArityT9 Pure + +comparePureArityT10 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j) k -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT10 = compareGenArityT10 Pure + +comparePureArityT11 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k) l -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT11 = compareGenArityT11 Pure + +comparePureArityT12 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l) m -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT12 = compareGenArityT12 Pure + +comparePureArityT13 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m) n -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT13 = compareGenArityT13 Pure + +comparePureArityT14 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n) o -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT14 = compareGenArityT14 Pure + +comparePureArityT15 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) p -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT15 = compareGenArityT15 Pure + +comparePureArityT16 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) q -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT16 = compareGenArityT16 Pure + +comparePureArityT17 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) r -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT17 = compareGenArityT17 Pure + +comparePureArityT18 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) s -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT18 = compareGenArityT18 Pure + +comparePureArityT19 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) t -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT19 = compareGenArityT19 Pure + +comparePureArityT20 :: TypedNoNameScript (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) u -> SourceCode -> IO (Either T.Text Executable) +comparePureArityT20 = compareGenArityT20 Pure + + + + + + +lambdaT1 :: FunctionName -> FnT a b +lambdaT1 fname = FnT . pack $ [istr| \a -> #{fname} a|] + +lambdaT2 :: FunctionName -> FnT (a,b) c +lambdaT2 fname = FnT . pack $ [istr| \(a, b) -> #{fname} a b|] + +lambdaT3 :: FunctionName -> FnT (a,b,c) d +lambdaT3 fname = FnT . pack $ [istr| \(a, b, c) -> #{fname} a b c|] + +lambdaT4 :: FunctionName -> FnT (a,b,c,d) e +lambdaT4 fname = FnT . pack $ [istr| \(a, b, c, d) -> #{fname} a b c d|] + +lambdaT5 :: FunctionName -> FnT (a,b,c,d,e) f +lambdaT5 fname = FnT . pack $ [istr| \(a, b, c, d, e) -> #{fname} a b c d e|] + +lambdaT6 :: FunctionName -> FnT (a,b,c,d,e,f) g +lambdaT6 fname = FnT . pack $ [istr| \(a, b, c, d, e, f) -> #{fname} a b c d e f|] + +lambdaT7 :: FunctionName -> FnT (a,b,c,d,e,f,g) h +lambdaT7 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g) -> #{fname} a b c d e f g|] + +lambdaT8 :: FunctionName -> FnT (a,b,c,d,e,f,g,h) i +lambdaT8 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h) -> #{fname} a b c d e f g h|] + +lambdaT9 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i) j +lambdaT9 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i) -> #{fname} a b c d e f g h i|] + +lambdaT10 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j) k +lambdaT10 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j) -> #{fname} a b c d e f g h i j|] + +lambdaT11 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j,k) l +lambdaT11 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k) -> #{fname} a b c d e f g h i j k|] + +lambdaT12 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j,k,l) m +lambdaT12 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l) -> #{fname} a b c d e f g h i j k l|] + +lambdaT13 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j,k,l,m) n +lambdaT13 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m) -> #{fname} a b c d e f g h i j k l m|] + +lambdaT14 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j,k,l,m,n) o +lambdaT14 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> #{fname} a b c d e f g h i j k l m n|] + +lambdaT15 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) p +lambdaT15 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> #{fname} a b c d e f g h i j k l m n o|] + +lambdaT16 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) q +lambdaT16 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> #{fname} a b c d e f g h i j k l m n o p|] + +lambdaT17 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) r +lambdaT17 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> #{fname} a b c d e f g h i j k l m n o p q|] + +lambdaT18 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) s +lambdaT18 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> #{fname} a b c d e f g h i j k l m n o p q r|] + +lambdaT19 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) t +lambdaT19 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> #{fname} a b c d e f g h i j k l m n o p q r s|] + +lambdaT20 :: FunctionName -> FnT (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) u +lambdaT20 fname = FnT . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> #{fname} a b c d e f g h i j k l m n o p q r s t|] + + + + +-- hask> lift Pure f +-- take a pure function and make it monadic or just leave it as is +-- this comes into effect when writing the expression +lift :: Purity -> FnT a b -> FnHKT a b +lift arity = FnHKT arity . getFnT + + +-- Typed monadic actions of some arity + +-- compareMonadicArityT1 +-- :: TypedNoNameScript a b-> SourceCode -> IO (Either T.Text Executable) +-- compareMonadicArityT1 = compareFuncTyped thing + +-- thing :: FunctionName -> FnHKT a b +-- thing = undefined + + +makeNames :: IO (T.Text,T.Text,T.Text) +makeNames = do + testVarName <- ((<>) "t") <$> randomAlphaNumCamelCaseName 5 + -- Must start with a Capital + moduleName <- ((<>) "M") <$> randomAlphaNumCamelCaseName 5 + testFuncName <- ((<>) "f") <$> randomAlphaNumCamelCaseName 5 + pure (testVarName, moduleName, testFuncName) + +compareFuncHKT + :: forall a b. + (FunctionName -> FnHKT a b) + -- ^ Essentially, this means pick the arity of the problem + -> TypedNoNameScript a b + -- ^ The provided solution and input data as a haskell module + -> SourceCode + -- ^ User func name + -> IO (Either T.Text Executable) +compareFuncHKT mkFn mkScript sourceCode = do -- (fnameUser, userScript) = do + (testVarName, moduleName, testFuncName) <- makeNames + + let + testLibScript :: Script + testLibScript = (getTypedNoNameScript mkScript) (ModuleName moduleName) testFuncName testVarName (TypeInfo Proxy Proxy) + locatedTestLib :: LocatedTestModule + locatedTestLib = LocatedTestModule $ locate [PathSegment moduleName] $ testLibScript + + settings_ = def + userModule = mkUserModule' settings_ $ _sourceCode_code sourceCode + -- TODO: pass ModuleName here + mainModule = genMakeMainComparativeTypedTestScriptHKT + mkFn + testVarName + (localImport $ getLocatedUserModule userModule, _sourceCode_target sourceCode) + (localImport $ getLocatedTestModule locatedTestLib, testFuncName) + locatedMainModule = LocatedTestModule $ locate [PathSegment "Main"] mainModule + + pure $ Right $ toCompareExe userModule locatedTestLib locatedMainModule + + +-- Link and call genMakeMainComparativeTestScript with args to customize it +compareFuncTyped + :: forall a b. + (FunctionName -> FnT a b) + -- ^ Essentially, this means pick the arity of the problem + -> TypedNoNameScript a b + -- ^ The provided solution and input data as a haskell module + -> SourceCode + -- ^ User func name + -> IO (Either T.Text Executable) +compareFuncTyped mkFn mkScript sourceCode = do -- (fnameUser, userScript) = do + (testVarName, moduleName, testFuncName) <- makeNames + let + testLibScript :: Script + testLibScript = (getTypedNoNameScript mkScript) (ModuleName moduleName) testFuncName testVarName (TypeInfo Proxy Proxy) + locatedTestLib :: LocatedTestModule + locatedTestLib = LocatedTestModule $ locate [PathSegment moduleName] $ testLibScript + + settings_ = def + userModule = mkUserModule' settings_ $ _sourceCode_code sourceCode + -- TODO: pass ModuleName here + mainModule = genMakeMainComparativeTypedTestScript + mkFn + testVarName + (localImport $ getLocatedUserModule userModule, _sourceCode_target sourceCode) + (localImport $ getLocatedTestModule locatedTestLib, testFuncName) + locatedMainModule = LocatedTestModule $ locate [PathSegment "Main"] mainModule + + pure $ Right $ toCompareExe userModule locatedTestLib locatedMainModule + +-- Link and call genMakeMainComparativeTestScript with args to customize it +compareFunc + :: (FunctionName -> Fn) + -- ^ Essentially, this means pick the arity of the problem + -> NoNameScript + -- ^ The provided solution and input data as a haskell module + -> SourceCode + -- ^ User func name + -> IO (Either T.Text Executable) +compareFunc mkFn mkScript sourceCode = do -- (fnameUser, userScript) = do + (testVarName, moduleName, testFuncName) <- makeNames + let + testLibScript :: Script + testLibScript = (getNoNameScript mkScript) (ModuleName moduleName) testFuncName testVarName + locatedTestLib :: LocatedTestModule + locatedTestLib = LocatedTestModule $ locate [PathSegment moduleName] $ testLibScript + + settings_ = def + userModule = mkUserModule' settings_ $ _sourceCode_code sourceCode + -- TODO: pass ModuleName here + mainModule = genMakeMainComparativeTestScript + mkFn + testVarName + (localImport $ getLocatedUserModule userModule, _sourceCode_target sourceCode) + (localImport $ getLocatedTestModule locatedTestLib, testFuncName) + locatedMainModule = LocatedTestModule $ locate [PathSegment "Main"] mainModule + + pure $ Right $ toCompareExe userModule locatedTestLib locatedMainModule + +-- randomAlphaNumCamelCaseName :: Int -> IO T.Text +-- randomAlphaNumCamelCaseName numWords = do +-- words <- replicateM numWords randomWord +-- pure $ T.concat $ zipWith capitalize [0..] words +-- where +-- alphaNum = ['a'..'z'] ++ ['0'..'9'] +-- randomWord :: IO T.Text +-- randomWord = do +-- len <- randomRIO (3, 8) +-- chars <- replicateM len $ do +-- idx <- randomRIO (0, length alphaNum - 1) +-- pure $ alphaNum !! idx +-- pure $ T.pack chars +-- capitalize :: Int -> T.Text -> T.Text +-- capitalize 0 w = w -- first word stays lowercase +-- capitalize _ w = case T.uncons w of +-- Nothing -> w +-- Just (c, rest) -> T.cons (toUpper c) rest +randomAlphaNumCamelCaseName :: Int -> IO T.Text +randomAlphaNumCamelCaseName numWords = do + words <- replicateM numWords randomWord + pure $ T.concat $ zipWith capitalize [0..] words + where + alphaNum = ['a'..'z'] ++ ['0'..'9'] + randomWord :: IO T.Text + randomWord = do + len <- randomRIO (3, 8) + chars <- replicateM len $ do + idx <- randomRIO (0, length alphaNum - 1) + pure $ alphaNum !! idx + pure $ T.pack chars + capitalize :: Int -> T.Text -> T.Text + capitalize n w + | n == 0 = w -- first word stays lowercase + | otherwise = case T.uncons w of + Nothing -> w + Just (c, rest) -> T.cons (toUpper c) rest + +type TestScript = Script + + +-- Perhaps we can derive this func we pass as an arg? +genMakeMainComparativeTestScript + :: (FunctionName -> Fn) + -> VarName + -> (Import, FunctionName) -- UserModuleName -- In theory, we could directly get this from the Import type + -> (Import, FunctionName) -- TestModule -- In theory, we could directly get this from the Import type + -> TestScript +genMakeMainComparativeTestScript mkF testValueName (userModule, fnameUser) (testModule, fnameCompare) = Script $ pack [istr| +module Main where + +import Control.Monad (mapM) +#{showImportLine userModule} +#{showImportLine testModule} + + + +--userF, solutionF +userF = #{getFn . mkF $ importName (getImportName userModule) <> "." <> fnameUser} +solutionF = #{getFn . mkF $ importName (getImportName testModule) <> "." <> fnameCompare} + +main :: IO () +main = do + inputs <- #{importName $ getImportName testModule}.#{testValueName} -- inputs :: (ToJSON a, FromJSON a) => a + valsUser <- mapM userF inputs + valsOurSolution <- mapM solutionF inputs + print $ zipWith (==) valsUser valsOurSolution +|] + + +-- Perhaps we can derive this func we pass as an arg? +genMakeMainComparativeTypedTestScript + :: (FunctionName -> FnT a b) + -> VarName + -> (Import, FunctionName) -- UserModuleName -- In theory, we could directly get this from the Import type + -> (Import, FunctionName) -- TestModule -- In theory, we could directly get this from the Import type + -> TestScript +genMakeMainComparativeTypedTestScript mkF testValueName (userModule, fnameUser) (testModule, fnameCompare) = Script $ pack [istr| +module Main where + +import Control.Monad (mapM) +#{showImportLine userModule} +#{showImportLine testModule} +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Aeson as Aeson +import RunGhc.MakeTest + + +--userF, solutionF -- should i use the proxies to assert the types here? +userF = #{getFnT . mkF $ importName (getImportName userModule) <> "." <> fnameUser} +solutionF = #{getFnT . mkF $ importName (getImportName testModule) <> "." <> fnameCompare} + +main :: IO () +main = do + inputs <- #{importName $ getImportName testModule}.#{testValueName} -- inputs :: (ToJSON a, FromJSON a) => a + valsUser <- mapM userF inputs + valsOurSolution <- mapM solutionF inputs + -- TODO: should we add in a stripMetadata (for functions)? + let x = zipWith3 (\outUser expec_ inp -> TryCodeResult inp outUser expec_ (outUser == expec_)) valsUser valsOurSolution inputs + LBS.putStrLn $ Aeson.encode x +|] + +showFnHKTExpression :: FnHKT a b -> T.Text +showFnHKTExpression f = ensureIO (purity f) "pure ." <> (getFnHKTLambda f) + where + ensureIO :: Purity -> T.Text -> T.Text + ensureIO b t = case b of + Impure -> "" + Pure -> t + + +genMakeMainComparativeTypedTestScriptHKT + :: (FunctionName -> FnHKT a b) + -> VarName + -> (Import, FunctionName) -- UserModuleName -- In theory, we could directly get this from the Import type + -> (Import, FunctionName) -- TestModule -- In theory, we could directly get this from the Import type + -> TestScript +genMakeMainComparativeTypedTestScriptHKT mkF testValueName (userModule, fnameUser) (testModule, fnameCompare) = Script $ pack [istr| +module Main where + +import Control.Monad (mapM) +#{showImportLine userModule} +#{showImportLine testModule} +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Aeson as Aeson +import RunGhc.MakeTest + +userF = #{userF_expr} +solutionF = #{solutionF_expr} + +-- Compare +main :: IO () +main = do + inputs <- #{importName $ getImportName testModule}.#{testValueName} + -- How can we do random inputs? + valsUser <- mapM userF inputs + valsOurSolution <- mapM solutionF inputs + let x = zipWith3 (\outUser expec_ inp -> TryCodeResult inp outUser expec_ (outUser == expec_)) valsUser valsOurSolution inputs + LBS.putStrLn $ Aeson.encode x +|] + where + userF_expr = showFnHKTExpression . mkF $ importName (getImportName userModule) <> "." <> fnameUser + solutionF_expr = showFnHKTExpression . mkF $ importName (getImportName testModule) <> "." <> fnameCompare + +newtype ImportName = ImportName { importName :: T.Text } +getImportName :: Import -> ImportName +getImportName imp = ImportName $ fromMaybe (combine $ _import_pathSeg imp) (_import_qualifiedName imp) + where + combine = T.intercalate "." . fmap getPathSegment +-- get either qualified name or just the module name as path +-- keeping in mind that everything is technically a qualified import +-- where if we havent overrided the name it is just the Module's name itself +-- eg. import Data.Text ; f = Data.Text.pack + +newtype TypedExpression a + = TypedExpression T.Text + +newtype Expression = Expression { getExpression :: T.Text } +-- To Enable a TypedExpression + --where + -- In theory, we could do something like this to typecheck a singular expression, before we include it in the script gen + --mkExpression :: (a -> IO b) -> IO b + --mkExpression f = $([e| 1 + 1 + g|] ) + +newtype TypedName a = TypedName { getTypedReference :: T.Text } + +-- In theory we could do: +-- apply :: Function (a ': xs) -> TypedName a -> Function xs +-- +-- and TypedName is gen'd by: +-- writeHaskellTopLevelVar :: VarName -> Expression -> TypedName + +data FnT a b = FnT { getFnT :: T.Text } + +data FnHKT a b = FnHKT + { purity :: Purity + , getFnHKTLambda :: T.Text + } + + + +-- eg f1 = "userF = " <> liftWhenPure f1 <> lambdaString + + +newtype Fn = Fn { getFn :: T.Text } +chainFn :: Fn -> Fn -> Fn +chainFn f1 f2 = Fn $ getFn (wrap f1) <> " . " <> getFn (wrap f2) + +chainFnT :: FnT a b -> FnT b c -> FnT a c +chainFnT f1 f2 = FnT $ getFnT (wrapT f1) <> " . " <> getFnT (wrapT f2) + +wrapT :: FnT a b -> FnT a b +wrapT f = FnT ("(" <> getFnT f <> ")") + +wrap :: Fn -> Fn +wrap f = Fn $ "(" <> getFn f <> ")" + +-- | TODO: this should really be (m b) or even (m a) but I have no idea how to do this just yet +------- :: Fn a b -> FnT a (m a) +liftFnT :: FnT a b -> FnT a b +liftFnT f = pure_ `chainFnT` f + where pure_ = FnT "pure" + +liftFn :: Fn -> Fn +liftFn f = pure_ `chainFn` f + where pure_ = Fn "pure" + +-- This is the `id` function +mkF1 :: FunctionName -> Fn +mkF1 fname = Fn . pack $ [istr| \a -> #{fname} a|] + +mkF2 :: FunctionName -> Fn +mkF2 fname = Fn . pack $ [istr| \(a, b) -> #{fname} a b|] + +mkF3 :: FunctionName -> Fn +mkF3 fname = Fn . pack $ [istr| \(a, b, c) -> #{fname} a b c|] + +mkF4 :: FunctionName -> Fn +mkF4 fname = Fn . pack $ [istr| \(a, b, c, d) -> #{fname} a b c d|] + +mkF5 :: FunctionName -> Fn +mkF5 fname = Fn . pack $ [istr| \(a, b, c, d, e) -> #{fname} a b c d e|] + +mkF6 :: FunctionName -> Fn +mkF6 fname = Fn . pack $ [istr| \(a, b, c, d, e, f) -> #{fname} a b c d e f|] + +mkF7 :: FunctionName -> Fn +mkF7 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g) -> #{fname} a b c d e f g|] + +mkF8 :: FunctionName -> Fn +mkF8 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h) -> #{fname} a b c d e f g h|] + +mkF9 :: FunctionName -> Fn +mkF9 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i) -> #{fname} a b c d e f g h i|] + +mkF10 :: FunctionName -> Fn +mkF10 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j) -> #{fname} a b c d e f g h i j|] + +mkF11 :: FunctionName -> Fn +mkF11 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k) -> #{fname} a b c d e f g h i j k|] + +mkF12 :: FunctionName -> Fn +mkF12 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l) -> #{fname} a b c d e f g h i j k l|] + +mkF13 :: FunctionName -> Fn +mkF13 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m) -> #{fname} a b c d e f g h i j k l m|] + +mkF14 :: FunctionName -> Fn +mkF14 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> #{fname} a b c d e f g h i j k l m n|] + +mkF15 :: FunctionName -> Fn +mkF15 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> #{fname} a b c d e f g h i j k l m n o|] + +mkF16 :: FunctionName -> Fn +mkF16 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> #{fname} a b c d e f g h i j k l m n o p|] + +mkF17 :: FunctionName -> Fn +mkF17 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> #{fname} a b c d e f g h i j k l m n o p q|] + +mkF18 :: FunctionName -> Fn +mkF18 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> #{fname} a b c d e f g h i j k l m n o p q r|] + +mkF19 :: FunctionName -> Fn +mkF19 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> #{fname} a b c d e f g h i j k l m n o p q r s|] + +mkF20 :: FunctionName -> Fn +mkF20 fname = Fn . pack $ [istr| \(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> #{fname} a b c d e f g h i j k l m n o p q r s t|] + + + +arity1 :: T a -> T a +arity1 = id + +arity2 :: T (a, b) -> (T a, T b) +arity2 _ = (type_, type_) + +arity3 :: T (a, b, c) -> (T a, T b, T c) +arity3 _ = (type_, type_, type_) + +arity4 :: T (a, b, c, d) -> (T a, T b, T c, T d) +arity4 _ = (type_, type_, type_, type_) + +arity5 :: T (a, b, c, d, e) -> (T a, T b, T c, T d, T e) +arity5 _ = (type_, type_, type_, type_, type_) + +arity6 :: T (a, b, c, d, e, f) -> (T a, T b, T c, T d, T e, T f) +arity6 _ = (type_, type_, type_, type_, type_, type_) + +arity7 :: T (a, b, c, d, e, f, g) -> (T a, T b, T c, T d, T e, T f, T g) +arity7 _ = (type_, type_, type_, type_, type_, type_, type_) + +arity8 :: T (a, b, c, d, e, f, g, h) -> (T a, T b, T c, T d, T e, T f, T g, T h) +arity8 _ = (type_, type_, type_, type_, type_, type_, type_, type_) + +arity9 :: T (a, b, c, d, e, f, g, h, i) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i) +arity9 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity10 :: T (a, b, c, d, e, f, g, h, i, j) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j) +arity10 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity11 :: T (a, b, c, d, e, f, g, h, i, j, k) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j, T k) +arity11 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity12 :: T (a, b, c, d, e, f, g, h, i, j, k, l) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j, T k, T l) +arity12 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity13 :: T (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j, T k, T l, T m) +arity13 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity14 :: T (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j, T k, T l, T m, T n) +arity14 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity15 :: T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j, T k, T l, T m, T n, T o) +arity15 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity16 :: T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j, T k, T l, T m, T n, T o, T p) +arity16 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity17 :: T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j, T k, T l, T m, T n, T o, T p, T q) +arity17 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity18 :: T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j, T k, T l, T m, T n, T o, T p, T q, T r) +arity18 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity19 :: T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j, T k, T l, T m, T n, T o, T p, T q, T r, T s) +arity19 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity20 :: T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> (T a, T b, T c, T d, T e, T f, T g, T h, T i, T j, T k, T l, T m, T n, T o, T p, T q, T r, T s, T t) +arity20 _ = (type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_, type_) + +arity1Str :: Typeable a => T a -> String +arity1Str = show . typeRep + +arity2Str :: (Typeable a, Typeable b) => T (a, b) -> (String, String) +arity2Str x = + let (a, b) = arity2 x + in (show (typeRep a), show (typeRep b)) + +arity3Str :: (Typeable a, Typeable b, Typeable c) => T (a, b, c) -> (String, String, String) +arity3Str x = + let (a, b, c) = arity3 x + in (show (typeRep a), show (typeRep b), show (typeRep c)) + +arity4Str :: (Typeable a, Typeable b, Typeable c, Typeable d) => T (a, b, c, d) -> (String, String, String, String) +arity4Str x = + let (a, b, c, d) = arity4 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d)) + +arity5Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => T (a, b, c, d, e) -> (String, String, String, String, String) +arity5Str x = + let (a, b, c, d, e) = arity5 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e)) + +arity6Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) => T (a, b, c, d, e, f) -> (String, String, String, String, String, String) +arity6Str x = + let (a, b, c, d, e, f) = arity6 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f)) + +arity7Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g) => T (a, b, c, d, e, f, g) -> (String, String, String, String, String, String, String) +arity7Str x = + let (a, b, c, d, e, f, g) = arity7 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g)) + +arity8Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h) => T (a, b, c, d, e, f, g, h) -> (String, String, String, String, String, String, String, String) +arity8Str x = + let (a, b, c, d, e, f, g, h) = arity8 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h)) + +arity9Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i) => T (a, b, c, d, e, f, g, h, i) -> (String, String, String, String, String, String, String, String, String) +arity9Str x = + let (a, b, c, d, e, f, g, h, i') = arity9 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i')) + +arity10Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j) => T (a, b, c, d, e, f, g, h, i, j) -> (String, String, String, String, String, String, String, String, String, String) +arity10Str x = + let (a, b, c, d, e, f, g, h, i', j) = arity10 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j)) + +arity11Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j, Typeable k) => T (a, b, c, d, e, f, g, h, i, j, k) -> (String, String, String, String, String, String, String, String, String, String, String) +arity11Str x = + let (a, b, c, d, e, f, g, h, i', j, k) = arity11 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j), show (typeRep k)) + +arity12Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j, Typeable k, Typeable l) => T (a, b, c, d, e, f, g, h, i, j, k, l) -> (String, String, String, String, String, String, String, String, String, String, String, String) +arity12Str x = + let (a, b, c, d, e, f, g, h, i', j, k, l) = arity12 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j), show (typeRep k), show (typeRep l)) + +arity13Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j, Typeable k, Typeable l, Typeable m) => T (a, b, c, d, e, f, g, h, i, j, k, l, m) -> (String, String, String, String, String, String, String, String, String, String, String, String, String) +arity13Str x = + let (a, b, c, d, e, f, g, h, i', j, k, l, m) = arity13 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j), show (typeRep k), show (typeRep l), show (typeRep m)) + +arity14Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j, Typeable k, Typeable l, Typeable m, Typeable n) => T (a, b, c, d, e, f, g, h, i, j, k, l, m, n) -> (String, String, String, String, String, String, String, String, String, String, String, String, String, String) +arity14Str x = + let (a, b, c, d, e, f, g, h, i', j, k, l, m, n) = arity14 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j), show (typeRep k), show (typeRep l), show (typeRep m), show (typeRep n)) + +arity15Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j, Typeable k, Typeable l, Typeable m, Typeable n, Typeable o) => T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) -> (String, String, String, String, String, String, String, String, String, String, String, String, String, String, String) +arity15Str x = + let (a, b, c, d, e, f, g, h, i', j, k, l, m, n, o) = arity15 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j), show (typeRep k), show (typeRep l), show (typeRep m), show (typeRep n), show (typeRep o)) + +arity16Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j, Typeable k, Typeable l, Typeable m, Typeable n, Typeable o, Typeable p) => T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) -> (String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String) +arity16Str x = + let (a, b, c, d, e, f, g, h, i', j, k, l, m, n, o, p) = arity16 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j), show (typeRep k), show (typeRep l), show (typeRep m), show (typeRep n), show (typeRep o), show (typeRep p)) + +arity17Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j, Typeable k, Typeable l, Typeable m, Typeable n, Typeable o, Typeable p, Typeable q) => T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) -> (String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String) +arity17Str x = + let (a, b, c, d, e, f, g, h, i', j, k, l, m, n, o, p, q) = arity17 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j), show (typeRep k), show (typeRep l), show (typeRep m), show (typeRep n), show (typeRep o), show (typeRep p), show (typeRep q)) + +arity18Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j, Typeable k, Typeable l, Typeable m, Typeable n, Typeable o, Typeable p, Typeable q, Typeable r) => T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) -> (String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String) +arity18Str x = + let (a, b, c, d, e, f, g, h, i', j, k, l, m, n, o, p, q, r) = arity18 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j), show (typeRep k), show (typeRep l), show (typeRep m), show (typeRep n), show (typeRep o), show (typeRep p), show (typeRep q), show (typeRep r)) + +arity19Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j, Typeable k, Typeable l, Typeable m, Typeable n, Typeable o, Typeable p, Typeable q, Typeable r, Typeable s) => T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) -> (String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String) +arity19Str x = + let (a, b, c, d, e, f, g, h, i', j, k, l, m, n, o, p, q, r, s) = arity19 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j), show (typeRep k), show (typeRep l), show (typeRep m), show (typeRep n), show (typeRep o), show (typeRep p), show (typeRep q), show (typeRep r), show (typeRep s)) + +arity20Str :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j, Typeable k, Typeable l, Typeable m, Typeable n, Typeable o, Typeable p, Typeable q, Typeable r, Typeable s, Typeable t) => T (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> (String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String, String) +arity20Str x = + let (a, b, c, d, e, f, g, h, i', j, k, l, m, n, o, p, q, r, s, t) = arity20 x + in (show (typeRep a), show (typeRep b), show (typeRep c), show (typeRep d), show (typeRep e), show (typeRep f), show (typeRep g), show (typeRep h), show (typeRep i'), show (typeRep j), show (typeRep k), show (typeRep l), show (typeRep m), show (typeRep n), show (typeRep o), show (typeRep p), show (typeRep q), show (typeRep r), show (typeRep s), show (typeRep t)) + +-- runPure1 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure1 = genMakeMainComparativeTestScript liftPure1 + +-- runPure2 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure2 = genMakeMainComparativeTestScript liftPure2 + +-- runPure3 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure3 = genMakeMainComparativeTestScript liftPure3 + +-- runPure4 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure4 = genMakeMainComparativeTestScript liftPure4 + +-- runPure5 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure5 = genMakeMainComparativeTestScript liftPure5 + +-- runPure6 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure6 = genMakeMainComparativeTestScript liftPure6 + +-- runPure7 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure7 = genMakeMainComparativeTestScript liftPure7 + +-- runPure8 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure8 = genMakeMainComparativeTestScript liftPure8 + +-- runPure9 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure9 = genMakeMainComparativeTestScript liftPure9 + +-- runPure10 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure10 = genMakeMainComparativeTestScript liftPure10 + +-- runPure11 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure11 = genMakeMainComparativeTestScript liftPure11 + +-- runPure12 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure12 = genMakeMainComparativeTestScript liftPure12 + +-- runPure13 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure13 = genMakeMainComparativeTestScript liftPure13 + +-- runPure14 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure14 = genMakeMainComparativeTestScript liftPure14 + +-- runPure15 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure15 = genMakeMainComparativeTestScript liftPure15 + +-- runPure16 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure16 = genMakeMainComparativeTestScript liftPure16 + +-- runPure17 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure17 = genMakeMainComparativeTestScript liftPure17 + +-- runPure18 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure18 = genMakeMainComparativeTestScript liftPure18 + +-- runPure19 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure19 = genMakeMainComparativeTestScript liftPure19 + +-- runPure20 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runPure20 = genMakeMainComparativeTestScript liftPure20 + +-- runMonadic1 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic1 = genMakeMainComparativeTestScript mkF1 + +-- runMonadic2 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic2 = genMakeMainComparativeTestScript mkF2 + +-- runMonadic3 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic3 = genMakeMainComparativeTestScript mkF3 + +-- runMonadic4 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic4 = genMakeMainComparativeTestScript mkF4 + +-- runMonadic5 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic5 = genMakeMainComparativeTestScript mkF5 + +-- runMonadic6 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic6 = genMakeMainComparativeTestScript mkF6 + +-- runMonadic7 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic7 = genMakeMainComparativeTestScript mkF7 + +-- runMonadic8 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic8 = genMakeMainComparativeTestScript mkF8 + +-- runMonadic9 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic9 = genMakeMainComparativeTestScript mkF9 + +-- runMonadic10 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic10 = genMakeMainComparativeTestScript mkF10 + +-- runMonadic11 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic11 = genMakeMainComparativeTestScript mkF11 + +-- runMonadic12 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic12 = genMakeMainComparativeTestScript mkF12 + +-- runMonadic13 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic13 = genMakeMainComparativeTestScript mkF13 + +-- runMonadic14 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic14 = genMakeMainComparativeTestScript mkF14 + +-- runMonadic15 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic15 = genMakeMainComparativeTestScript mkF15 + +-- runMonadic16 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic16 = genMakeMainComparativeTestScript mkF16 + +-- runMonadic17 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic17 = genMakeMainComparativeTestScript mkF17 + +-- runMonadic18 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic18 = genMakeMainComparativeTestScript mkF18 + +-- runMonadic19 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic19 = genMakeMainComparativeTestScript mkF19 + +-- runMonadic20 :: FunctionName -> VarName -> Import -> Import -> TestScript +-- runMonadic20 = genMakeMainComparativeTestScript mkF20 + --where + -- In theory, we could do something like this to typecheck a singular expression, before we include it in the script gen + --mkExpression :: (a -> IO b) -> IO b + --mkExpression f = $([e| 1 + 1 + g|] ) + + + +type EitherDesign = Either +script + :: forall a + . Typeable a + => LocatedUserModule -- The user's solution, to make + -> LocatedUserModule -- Our Correct Solution, to make an import + -> EitherDesign [[a]] [a] + -- We could choose the design of this being a list of type names OR just the tests themselves + -- which would be all we need to get the type info +script = undefined +-- script fname = [istr| +-- main = do +-- inputs <- makeTest #{test11Inputs} + +-- valsUser <- mapM User.#{fname} inputs +-- valsOurSolution <- mapM Solution.#{fname} inputs + +-- print $ zipWith (==) valsUser valsOurSolution + +-- |] + + +data Generator + = StaticConstant T.Text + | Unfoldr + +newtype Tests' = Tests' T.Text +newtype Filter = Filter T.Text +newtype Count = Count Int + +makeTests :: Count -> Filter -> Generator -> Tests' +makeTests (Count ct) (Filter filt) generator = Tests' $ + "Prelude.take " <> (T.pack $ show ct) + <> " $ " + <> " filter " + <> filt + <> " " + <> renderGenerator generator + +renderGenerator :: Generator -> T.Text +renderGenerator = \case + StaticConstant t -> t + Unfoldr -> "[]" + + +instance ToJSON ExitCode +instance FromJSON ExitCode diff --git a/src/RunGhc/MakeTest/FFI.hs b/src/RunGhc/MakeTest/FFI.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/MakeTest/FFI.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module RunGhc.MakeTest.FFI where + +import Data.Aeson +import Data.Kind (Type) +import GHC.TypeLits (Nat,TypeError, ErrorMessage(..)) +import RunGhc.MakeTest.HKTs +--import RunGhc.MakeTest.TypeSig (RequireValid) +-------------------------------------------------------------------------------- +-- Extract concrete type from a Slot +-------------------------------------------------------------------------------- + +type family SlotType (s :: Slot) :: Type where + SlotType ('MkSlot e t) = t + +-------------------------------------------------------------------------------- +-- Split into inputs and output +-------------------------------------------------------------------------------- + +type family InputSlots (xs :: [Slot]) :: [Slot] where + InputSlots '[] = TypeError ('Text "Empty signature") + InputSlots '[x] = '[] + InputSlots (x ': xs) = x ': InputSlots xs + +type family OutputSlot (xs :: [Slot]) :: Slot where + OutputSlot '[] = TypeError ('Text "Empty signature") + OutputSlot '[x] = x + OutputSlot (x ': xs) = OutputSlot xs + +-------------------------------------------------------------------------------- +-- Convert slot list to tuple of concrete types +-------------------------------------------------------------------------------- + +type family ToTuple (xs :: [Slot]) :: Type where + ToTuple '[] = () + ToTuple '[a] = SlotType a + ToTuple '[a, b] = (SlotType a, SlotType b) + ToTuple '[a, b, c] = (SlotType a, SlotType b, SlotType c) + ToTuple '[a, b, c, d] = (SlotType a, SlotType b, SlotType c, SlotType d) + ToTuple '[a, b, c, d, e] = (SlotType a, SlotType b, SlotType c, SlotType d, SlotType e) + ToTuple '[a, b, c, d, e, f] = (SlotType a, SlotType b, SlotType c, SlotType d, SlotType e, SlotType f) + ToTuple '[a, b, c, d, e, f, g] = (SlotType a, SlotType b, SlotType c, SlotType d, SlotType e, SlotType f, SlotType g) + ToTuple '[a, b, c, d, e, f, g, h] = (SlotType a, SlotType b, SlotType c, SlotType d, SlotType e, SlotType f, SlotType g, SlotType h) + +-------------------------------------------------------------------------------- +-- InputTuple and OutputType for Sig +-------------------------------------------------------------------------------- + +type family InputTuple (s :: Sig) :: Type where + InputTuple ('MkSig cs slots) = ToTuple (InputSlots (RequireValid slots)) + +type family OutputType (s :: Sig) :: Type where + OutputType ('MkSig cs slots) = SlotType (OutputSlot (RequireValid slots)) + +-------------------------------------------------------------------------------- +-- Wrapper for a signature's values +-------------------------------------------------------------------------------- + +newtype SigVal (xs :: [Slot]) = SigVal { unSigVal :: ToTuple xs } + +instance (FromJSON (ToTuple xs)) => FromJSON (SigVal xs) where + parseJSON v = SigVal <$> parseJSON v + +instance (ToJSON (ToTuple xs)) => ToJSON (SigVal xs) where + toJSON (SigVal x) = toJSON x + + + + +-------------------------------------------------------------------------------- +-- Extract var bindings from a TyExpr (returns list of (Nat, Type) pairs) +-- The Type is the concrete test type from the Slot, not from the TyExpr +-------------------------------------------------------------------------------- + +type family ExtractVars (e :: TyExpr) (t :: Type) :: [(Nat, Type)] where + ExtractVars ('TVar n) t = '[ '(n, t) ] + ExtractVars ('TConT _) _ = '[] + ExtractVars ('TCon1 _) _ = '[] + ExtractVars ('TCon2 _) _ = '[] + ExtractVars ('TApp f x) t = Append (ExtractVarsFromApp f t) (ExtractVarsFromApp x t) + +-- For TApp, we can't easily know what concrete type the inner part has +-- So we just extract the var IDs and mark them with the outer type +-- This is a simplification - for full correctness you'd need to track types through application +type family ExtractVarsFromApp (e :: TyExpr) (t :: Type) :: [(Nat, Type)] where + ExtractVarsFromApp ('TVar n) t = '[ '(n, t) ] + ExtractVarsFromApp ('TConT _) _ = '[] + ExtractVarsFromApp ('TCon1 _) _ = '[] + ExtractVarsFromApp ('TCon2 _) _ = '[] + ExtractVarsFromApp ('TApp f x) t = Append (ExtractVarsFromApp f t) (ExtractVarsFromApp x t) + +-------------------------------------------------------------------------------- +-- Collect all var bindings from a slot list +-------------------------------------------------------------------------------- + +type family CollectVarBindings (xs :: [Slot]) :: [(Nat, Type)] where + CollectVarBindings '[] = '[] + CollectVarBindings ('MkSlot e t ': xs) = Append (ExtractVarsSimple e t) (CollectVarBindings xs) + +-- Simplified: only check top-level TVar, not nested in TApp +-- This catches the common case: Var 0 Int, Var 0 Bool would conflict +type family ExtractVarsSimple (e :: TyExpr) (t :: Type) :: [(Nat, Type)] where + ExtractVarsSimple ('TVar n) t = '[ '(n, t) ] + ExtractVarsSimple ('TConT _) _ = '[] + ExtractVarsSimple ('TCon1 _) _ = '[] + ExtractVarsSimple ('TCon2 _) _ = '[] + ExtractVarsSimple ('TApp ('TCon1 f) ('TVar n)) t = '[ '(n, UnwrapApp1 f t) ] + ExtractVarsSimple ('TApp ('TApp ('TCon2 f) ('TVar n)) ('TVar m)) t = + '[ '(n, UnwrapApp2Fst f t), '(m, UnwrapApp2Snd f t) ] + ExtractVarsSimple ('TApp _ _) _ = '[] -- fallback for complex cases + +-- Unwrap concrete type from App1: if t = [Int], unwrap to Int +type family UnwrapApp1 (f :: Type -> Type) (t :: Type) :: Type where + UnwrapApp1 f (f a) = a + UnwrapApp1 f t = t -- fallback + +-- Unwrap first type arg from App2: if t = Either Int Bool, get Int +type family UnwrapApp2Fst (f :: Type -> Type -> Type) (t :: Type) :: Type where + UnwrapApp2Fst f (f a b) = a + UnwrapApp2Fst f t = t -- fallback + +-- Unwrap second type arg from App2: if t = Either Int Bool, get Bool +type family UnwrapApp2Snd (f :: Type -> Type -> Type) (t :: Type) :: Type where + UnwrapApp2Snd f (f a b) = b + UnwrapApp2Snd f t = t -- fallback + +-------------------------------------------------------------------------------- +-- Find conflict in var bindings +-------------------------------------------------------------------------------- + +type family FindConflictInBindings (xs :: [(Nat, Type)]) :: Maybe (Nat, Type, Type) where + FindConflictInBindings '[] = 'Nothing + FindConflictInBindings ('(n, t) ': xs) = FindConflictFor n t xs (FindConflictInBindings xs) + +type family FindConflictFor (n :: Nat) (t :: Type) (xs :: [(Nat, Type)]) (rest :: Maybe (Nat, Type, Type)) :: Maybe (Nat, Type, Type) where + FindConflictFor n t '[] rest = rest + FindConflictFor n t ('(n', t') ': xs) rest = + If (EqNat n n' && Not (EqType t t')) + ('Just '(n, t, t')) + (FindConflictFor n t xs rest) + +-------------------------------------------------------------------------------- +-- RequireValid +-------------------------------------------------------------------------------- + +type family FindConflict (xs :: [Slot]) :: Maybe (Nat, Type, Type) where + FindConflict xs = FindConflictInBindings (CollectVarBindings xs) + +type family RequireValid (xs :: [Slot]) :: [Slot] where + RequireValid xs = RequireValid' xs (FindConflict xs) + +type family RequireValid' (xs :: [Slot]) (conflict :: Maybe (Nat, Type, Type)) :: [Slot] where + RequireValid' xs 'Nothing = xs + RequireValid' xs ('Just '(n, t1, t2)) = TypeError + ( 'Text "Type signature conflict for type variable 'Var " + ':<>: 'ShowType n ':<>: 'Text "'" + ':$$: 'Text "" + ':$$: 'Text " Used with type: " ':<>: 'ShowType t1 + ':$$: 'Text " Also used with: " ':<>: 'ShowType t2 + ':$$: 'Text "" + ':$$: 'Text "Each type variable must map to exactly one concrete type." + ) + +type family UnwrapIOProxy (a :: Type) :: Type where + UnwrapIOProxy (IO a) = a -- IO a -> a, Maybe a -> a, [] a -> a + UnwrapIOProxy a = a -- Int -> Int, Bool -> Bool diff --git a/src/RunGhc/MakeTest/HKTs.hs b/src/RunGhc/MakeTest/HKTs.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/MakeTest/HKTs.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module RunGhc.MakeTest.HKTs where + +import Data.Kind (Type, Constraint) +import GHC.TypeLits +import Data.List (intercalate) +import Data.Char (chr, ord) +import Data.Proxy +import Data.Typeable + +-------------------------------------------------------------------------------- +-- Core type expression language +-------------------------------------------------------------------------------- + +data TyExpr + = TVar Nat -- type variable: a, b, c + | TConT Type -- concrete type: Int, Bool + | TCon1 (Type -> Type) -- 1-arg constructor: [], Maybe + | TCon2 (Type -> Type -> Type) -- 2-arg constructor: Either + | TApp TyExpr TyExpr -- application: f x + +-------------------------------------------------------------------------------- +-- Slot: pairs a type expression with its concrete test type +-------------------------------------------------------------------------------- + +data Slot = MkSlot TyExpr Type + +-------------------------------------------------------------------------------- +-- Constraints +-------------------------------------------------------------------------------- + +data Constraint' = Cst (Type -> Constraint) Nat + +data Sig = MkSig [Constraint'] [Slot] + +-------------------------------------------------------------------------------- +-- Smart constructors +-------------------------------------------------------------------------------- + +-- Simple variable: a +type Var (n :: Nat) (t :: Type) = 'MkSlot ('TVar n) t + +-- Fixed concrete type +type Fix (t :: Type) = 'MkSlot ('TConT t) t + +-- App1: [a], Maybe a +type App1 (f :: Type -> Type) (n :: Nat) (t :: Type) = + 'MkSlot ('TApp ('TCon1 f) ('TVar n)) (f t) + +-- App2: Either a b +type App2 (f :: Type -> Type -> Type) (n :: Nat) (m :: Nat) (t1 :: Type) (t2 :: Type) = + 'MkSlot ('TApp ('TApp ('TCon2 f) ('TVar n)) ('TVar m)) (f t1 t2) + +-- App2L: Either Int a — left fixed +type App2L (f :: Type -> Type -> Type) (l :: Type) (n :: Nat) (t :: Type) = + 'MkSlot ('TApp ('TApp ('TCon2 f) ('TConT l)) ('TVar n)) (f l t) + +-- App2R: Either a Int — right fixed +type App2R (f :: Type -> Type -> Type) (n :: Nat) (r :: Type) (t :: Type) = + 'MkSlot ('TApp ('TApp ('TCon2 f) ('TVar n)) ('TConT r)) (f t r) + +-- Nested App1: [[a]], Maybe [a] +type App1Nested (f :: Type -> Type) (g :: Type -> Type) (n :: Nat) (t :: Type) = + 'MkSlot ('TApp ('TCon1 f) ('TApp ('TCon1 g) ('TVar n))) (f (g t)) + +-- App1 with fixed inner: [Int] -> considered fixed but using App1 structure +type App1Fix (f :: Type -> Type) (t :: Type) = + 'MkSlot ('TApp ('TCon1 f) ('TConT t)) (f t) + +-- For (a, [a]) pattern: a tuple where second element is a list of the first +type App2VarList (n :: Nat) (t :: Type) = + 'MkSlot + ('TApp ('TApp ('TCon2 (,)) ('TVar n)) ('TApp ('TCon1 []) ('TVar n))) + (t, [t]) +-------------------------------------------------------------------------------- +-- Type-level helpers +-------------------------------------------------------------------------------- + +type family EqNat (a :: Nat) (b :: Nat) :: Bool where + EqNat a a = 'True + EqNat a b = 'False + +type family EqType (a :: Type) (b :: Type) :: Bool where + EqType a a = 'True + EqType a b = 'False + +type family If (b :: Bool) (t :: k) (f :: k) :: k where + If 'True t f = t + If 'False t f = f + +type family (&&) (a :: Bool) (b :: Bool) :: Bool where + 'True && 'True = 'True + _ && _ = 'False + +type family Not (b :: Bool) :: Bool where + Not 'True = 'False + Not 'False = 'True + +type family Append (xs :: [k]) (ys :: [k]) :: [k] where + Append '[] ys = ys + Append (x ': xs) ys = x ': Append xs ys + +-------------------------------------------------------------------------------- +-- Extract all var IDs from a TyExpr +-------------------------------------------------------------------------------- + +type family GetVars (e :: TyExpr) :: [Nat] where + GetVars ('TVar n) = '[n] + GetVars ('TConT _) = '[] + GetVars ('TCon1 _) = '[] + GetVars ('TCon2 _) = '[] + GetVars ('TApp f x) = Append (GetVars f) (GetVars x) + +-------------------------------------------------------------------------------- +-- Reify TyExpr to user-facing string +-------------------------------------------------------------------------------- + +class ReifyTyExpr (e :: TyExpr) where + reifyTyExprUser :: Proxy e -> String + +instance KnownNat n => ReifyTyExpr ('TVar n) where + reifyTyExprUser _ = [chr (ord 'a' + fromIntegral (natVal (Proxy @n)))] + +instance Typeable t => ReifyTyExpr ('TConT t) where + reifyTyExprUser _ = show (typeRep (Proxy @t)) + +instance Typeable f => ReifyTyExpr ('TCon1 f) where + reifyTyExprUser _ = show (typeRep (Proxy @f)) + +instance Typeable f => ReifyTyExpr ('TCon2 f) where + reifyTyExprUser _ = show (typeRep (Proxy @f)) + +-- Special case: list application [x] instead of ([] x) +instance ReifyTyExpr x => ReifyTyExpr ('TApp ('TCon1 []) x) where + reifyTyExprUser _ = "[" ++ reifyTyExprUser (Proxy @x) ++ "]" + +-- General application +instance {-# OVERLAPPABLE #-} (ReifyTyExpr f, ReifyTyExpr x) => ReifyTyExpr ('TApp f x) where + reifyTyExprUser _ = + let fStr = reifyTyExprUser (Proxy @f) + xStr = reifyTyExprUser (Proxy @x) + xWrapped = if ' ' `elem` xStr then "(" ++ xStr ++ ")" else xStr + in fStr ++ " " ++ xWrapped + +-------------------------------------------------------------------------------- +-- Reify Slot +-------------------------------------------------------------------------------- + +class ReifySlot (s :: Slot) where + slotUser :: Proxy s -> String + slotTest :: Proxy s -> String + +instance (ReifyTyExpr e, Typeable t) => ReifySlot ('MkSlot e t) where + slotUser _ = reifyTyExprUser (Proxy @e) + slotTest _ = show (typeRep (Proxy @t)) + +-------------------------------------------------------------------------------- +-- Reify Slot list +-------------------------------------------------------------------------------- + +class ReifySlots (xs :: [Slot]) where + reifyUser :: Proxy xs -> [String] + reifyTest :: Proxy xs -> [String] + +instance ReifySlots '[] where + reifyUser _ = [] + reifyTest _ = [] + +instance (ReifySlot x, ReifySlots xs) => ReifySlots (x ': xs) where + reifyUser _ = slotUser (Proxy @x) : reifyUser (Proxy @xs) + reifyTest _ = slotTest (Proxy @x) : reifyTest (Proxy @xs) + +-------------------------------------------------------------------------------- +-- Reify Constraint +-------------------------------------------------------------------------------- + +class ReifyConstraint (c :: Constraint') where + reifyConstraint :: Proxy c -> String + +instance KnownNat n => ReifyConstraint ('Cst Eq n) where + reifyConstraint _ = "Eq " ++ [chr (ord 'a' + fromIntegral (natVal (Proxy @n)))] + +instance KnownNat n => ReifyConstraint ('Cst Ord n) where + reifyConstraint _ = "Ord " ++ [chr (ord 'a' + fromIntegral (natVal (Proxy @n)))] + +instance KnownNat n => ReifyConstraint ('Cst Show n) where + reifyConstraint _ = "Show " ++ [chr (ord 'a' + fromIntegral (natVal (Proxy @n)))] + +instance KnownNat n => ReifyConstraint ('Cst Num n) where + reifyConstraint _ = "Num " ++ [chr (ord 'a' + fromIntegral (natVal (Proxy @n)))] + +class ReifyConstraints (cs :: [Constraint']) where + reifyConstraints :: Proxy cs -> [String] + +instance ReifyConstraints '[] where + reifyConstraints _ = [] + +instance (ReifyConstraint c, ReifyConstraints cs) => ReifyConstraints (c ': cs) where + reifyConstraints _ = reifyConstraint (Proxy @c) : reifyConstraints (Proxy @cs) + +-------------------------------------------------------------------------------- +-- Reify full Sig +-------------------------------------------------------------------------------- + +class ReifySig (s :: Sig) where + showUserSig :: Proxy s -> String + showTestSig :: Proxy s -> String + reifyUserSig :: Proxy s -> [String] + reifyTestSig :: Proxy s -> [String] + +instance (ReifyConstraints cs, ReifySlots slots) => ReifySig ('MkSig cs slots) where + showUserSig _ = + let constraints = reifyConstraints (Proxy @cs) + types = reifyUser (Proxy @slots) + constraintPart = case constraints of + [] -> "" + [c] -> c ++ " => " + cs' -> "(" ++ intercalate ", " cs' ++ ") => " + in constraintPart ++ intercalate " -> " types + + showTestSig _ = intercalate " -> " (reifyTest (Proxy @slots)) + + reifyUserSig _ = reifyUser (Proxy @slots) + + reifyTestSig _ = reifyTest (Proxy @slots) + + +-- Show just the output type (last slot) for user view +showUserOutputType :: ReifySig sig => Proxy sig -> String +showUserOutputType p = case reifyUserFromSig p of + [] -> "" + xs -> last xs + +-- Show just the input types for user view +showUserInputTypes :: ReifySig sig => Proxy sig -> String +showUserInputTypes p = case reifyUserFromSig p of + [] -> "" + xs -> intercalate " -> " (init xs) + +-- Helper to get the list of user-facing type strings from a Sig +reifyUserFromSig :: ReifySig sig => Proxy sig -> [String] +reifyUserFromSig = reifyUserSig +-------------------------------------------------------------------------------- +-- ToConcrete: convert slot list to actual function type +-------------------------------------------------------------------------------- + +type family ToConcrete (xs :: [Slot]) :: Type where + ToConcrete '[] = TypeError ('Text "Empty signature") + ToConcrete '[ 'MkSlot _ t] = t + ToConcrete ('MkSlot _ t ': xs) = t -> ToConcrete xs + +-------------------------------------------------------------------------------- +-- ToConcreteFromSig: extract slots from Sig and convert +-------------------------------------------------------------------------------- + +type family ToConcreteFromSig (s :: Sig) :: Type where + ToConcreteFromSig ('MkSig cs slots) = ToConcrete slots + +-------------------------------------------------------------------------------- +-- Examples +-------------------------------------------------------------------------------- + +-- Simple: a -> a -> b +-- Test: Int -> Int -> Bool +type Simple = '[ Var 0 Int, Var 0 Int, Var 1 Bool ] + +-- With App1: [a] -> Maybe a -> a +-- Test: [Int] -> Maybe Int -> Int +type WithApp1 = '[ App1 [] 0 Int, App1 Maybe 0 Int, Var 0 Int ] + +-- With App2: Either a b -> a +-- Test: Either Int Bool -> Int +type WithEither = '[ App2 Either 0 1 Int Bool, Var 0 Int ] + +-- With App2L: Either String a -> a +-- Test: Either String Int -> Int +type WithEitherL = '[ App2L Either String 0 Int, Var 0 Int ] + +-- With App2R: Either a String -> a +-- Test: Either Int String -> Int +type WithEitherR = '[ App2R Either 0 String Int, Var 0 Int ] + +-- Nested: [[a]] -> [a] +-- Test: [[Int]] -> [Int] +type Nested = '[ App1Nested [] [] 0 Int, App1 [] 0 Int ] + +-- With constraint: Eq a => [a] -> Bool +type WithConstraint = 'MkSig + '[ 'Cst Eq 0 ] + '[ App1 [] 0 Int, Fix Bool ] + +-- Multiple constraints: (Eq a, Ord b) => a -> b -> Bool +type MultiConstraint = 'MkSig + '[ 'Cst Eq 0, 'Cst Ord 1 ] + '[ Var 0 Int, Var 1 Char, Fix Bool ] + +-------------------------------------------------------------------------------- +-- Usage examples (in GHCi) +-------------------------------------------------------------------------------- + +-- >>> reifyUser (Proxy @Simple) +-- ["a", "a", "b"] + +-- >>> reifyTest (Proxy @Simple) +-- ["Int", "Int", "Bool"] + +-- >>> reifyUser (Proxy @WithApp1) +-- ["[a]", "Maybe a", "a"] + +-- >>> reifyTest (Proxy @WithApp1) +-- ["[Int]", "Maybe Int", "Int"] + +-- >>> reifyUser (Proxy @WithEither) +-- ["Either a b", "a"] + +-- >>> reifyTest (Proxy @WithEither) +-- ["Either Int Bool", "Int"] + +-- >>> showUserSig (Proxy @WithConstraint) +-- "Eq a => [a] -> Bool" + +-- >>> showTestSig (Proxy @WithConstraint) +-- "[Int] -> Bool" + +-- >>> showUserSig (Proxy @MultiConstraint) +-- "(Eq a, Ord b) => a -> b -> Bool" + +-- >>> showTestSig (Proxy @MultiConstraint) +-- "Int -> Char -> Bool" + +-- >>> :kind! ToConcrete Simple +-- ToConcrete Simple :: Type +-- = Int -> Int -> Bool + +-- >>> :kind! ToConcreteFromSig WithConstraint +-- ToConcreteFromSig WithConstraint :: Type +-- = [Int] -> Bool + + +type App1Pair (f :: Type -> Type) (n :: Nat) (t :: Type) = + 'MkSlot + ('TApp ('TApp ('TCon2 (,)) ('TApp ('TCon1 f) ('TVar n))) ('TApp ('TCon1 f) ('TVar n))) + (f t, f t) + +-- Extract slots from Sig +type family SigSlots (s :: Sig) :: [Slot] where + SigSlots ('MkSig cs slots) = slots + +-- Special case: tuple application (a, b) instead of ((,) a b) +instance (ReifyTyExpr a, ReifyTyExpr b) => ReifyTyExpr ('TApp ('TApp ('TCon2 (,)) a) b) where + reifyTyExprUser _ = "(" ++ reifyTyExprUser (Proxy @a) ++ ", " ++ reifyTyExprUser (Proxy @b) ++ ")" diff --git a/src/RunGhc/MakeTest/TypeSig.hs b/src/RunGhc/MakeTest/TypeSig.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/MakeTest/TypeSig.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} + +module RunGhc.MakeTest.TypeSig where + +import Data.Kind (Type) +import GHC.TypeLits +import Data.List (intercalate) +import Data.Char (chr, ord) +import Data.Proxy +import Data.Typeable + +-------------------------------------------------------------------------------- +-- Type-level Slot definition +-------------------------------------------------------------------------------- + +data Slot + = Poly Nat Type -- polymorphic: var ID + concrete test type + | Fixed Type -- always concrete + +-------------------------------------------------------------------------------- +-- Type-level helpers +-------------------------------------------------------------------------------- + +type family EqNat (a :: Nat) (b :: Nat) :: Bool where + EqNat a a = 'True + EqNat a b = 'False + +type family EqType (a :: Type) (b :: Type) :: Bool where + EqType a a = 'True + EqType a b = 'False + +type family If (b :: Bool) (t :: k) (f :: k) :: k where + If 'True t f = t + If 'False t f = f + +type family (&&) (a :: Bool) (b :: Bool) :: Bool where + 'True && 'True = 'True + _ && _ = 'False + +type family Not (b :: Bool) :: Bool where + Not 'True = 'False + Not 'False = 'True +-------------------------------------------------------------------------------- +-- Validation: ensure same var ID always has same type +-------------------------------------------------------------------------------- + +type family ValidateSlot (id :: Nat) (t :: Type) (xs :: [Slot]) :: Bool where + ValidateSlot id t '[] = 'True + ValidateSlot id t (Fixed _ ': xs) = ValidateSlot id t xs + ValidateSlot id t (Poly id' t' ': xs) = + If (EqNat id id') + (If (EqType t t') (ValidateSlot id t xs) 'False) + (ValidateSlot id t xs) + +type family ValidateSig (xs :: [Slot]) :: Bool where + ValidateSig '[] = 'True + ValidateSig (Fixed _ ': xs) = ValidateSig xs + ValidateSig (Poly id t ': xs) = ValidateSlot id t xs && ValidateSig xs + +-- type family RequireValid (xs :: [Slot]) :: [Slot] where +-- RequireValid xs = If (ValidateSig xs) xs +-- (TypeError ('Text "Mismatched types for same type variable")) + +-- import GHC.TypeLits (TypeError, ErrorMessage(..)) + +type family FindConflict (xs :: [Slot]) :: Maybe (Nat, Type, Type) where + FindConflict '[] = 'Nothing + FindConflict (Fixed _ ': xs) = FindConflict xs + FindConflict (Poly id t ': xs) = FindConflictWith id t xs (FindConflict xs) + +-- Check if this (id, t) conflicts with anything in xs +-- Also takes the "rest" result in case we don't find a conflict here +type family FindConflictWith (id :: Nat) (t :: Type) (xs :: [Slot]) (rest :: Maybe (Nat, Type, Type)) :: Maybe (Nat, Type, Type) where + FindConflictWith id t '[] rest = rest + FindConflictWith id t (Fixed _ ': xs) rest = FindConflictWith id t xs rest + FindConflictWith id t (Poly id' t' ': xs) rest = + If (EqNat id id' && Not (EqType t t')) + ('Just '(id, t, t')) + (FindConflictWith id t xs rest) + +-------------------------------------------------------------------------------- +-- Validation with good error messages +-------------------------------------------------------------------------------- + +type family RequireValid (xs :: [Slot]) :: [Slot] where + RequireValid xs = RequireValid' xs (FindConflict xs) + +type family RequireValid' (xs :: [Slot]) (conflict :: Maybe (Nat, Type, Type)) :: [Slot] where + RequireValid' xs 'Nothing = xs + RequireValid' xs ('Just '(n, t1, t2)) = TypeError + ( 'Text "Type signature conflict for type variable '" + ':<>: 'Text "Poly " ':<>: 'ShowType n ':<>: 'Text "'" + ':$$: 'Text "" + ':$$: 'Text " Used with type: " ':<>: 'ShowType t1 + ':$$: 'Text " Also used with: " ':<>: 'ShowType t2 + ':$$: 'Text "" + ':$$: 'Text "Each type variable must map to exactly one concrete type." + ) + +-- type family RequireValid (xs :: [Slot]) :: [Slot] where +-- RequireValid xs = If (ValidateSig xs) xs +-- (TypeError +-- ( 'Text "Invalid type signature: " +-- ':$$: 'Text "Same type variable used with different concrete types." +-- ':$$: 'Text "Each type variable (Poly n t) must use the same 't' for a given 'n'." +-- ':$$: 'Text "" +-- ':$$: 'Text "Example of valid: [Poly 0 Int, Poly 0 Int, Poly 1 Bool]" +-- ':$$: 'Text "Example of invalid: [Poly 0 Int, Poly 0 Bool] -- 0 maps to both Int and Bool" +-- )) + + + +-------------------------------------------------------------------------------- +-- Convert to concrete function signature +-------------------------------------------------------------------------------- + +type family ToConcrete (xs :: [Slot]) :: Type where + ToConcrete xs = ToConcrete' (RequireValid xs) + +type family ToConcrete' (xs :: [Slot]) :: Type where + ToConcrete' '[Poly _ t] = t + ToConcrete' '[Fixed t] = t + ToConcrete' (Poly _ t ': xs) = t -> ToConcrete' xs + ToConcrete' (Fixed t ': xs) = t -> ToConcrete' xs + +-------------------------------------------------------------------------------- +-- Reify single slot to String +-------------------------------------------------------------------------------- + +class ReifySlot (s :: Slot) where + slotUser :: Proxy s -> String + slotTest :: Proxy s -> String + +instance (KnownNat n, Typeable t) => ReifySlot (Poly n t) where + slotUser _ = [chr (ord 'a' + fromIntegral (natVal (Proxy @n)))] + slotTest _ = show (typeRep (Proxy @t)) + +instance Typeable t => ReifySlot (Fixed t) where + slotUser _ = show (typeRep (Proxy @t)) + slotTest _ = show (typeRep (Proxy @t)) + +-------------------------------------------------------------------------------- +-- Reify whole signature to [String] +-------------------------------------------------------------------------------- + +class ReifySig (xs :: [Slot]) where + reifyUser :: Proxy xs -> [String] + reifyTest :: Proxy xs -> [String] + +instance ReifySig '[] where + reifyUser _ = [] + reifyTest _ = [] + +instance (ReifySlot x, ReifySig xs) => ReifySig (x ': xs) where + reifyUser _ = slotUser (Proxy @x) : reifyUser (Proxy @xs) + reifyTest _ = slotTest (Proxy @x) : reifyTest (Proxy @xs) + +-------------------------------------------------------------------------------- +-- Convenience: render as "a -> b -> c" +-------------------------------------------------------------------------------- + +showUserSig :: ReifySig xs => Proxy xs -> String +showUserSig p = intercalate " -> " (reifyUser p) + +showTestSig :: ReifySig xs => Proxy xs -> String +showTestSig p = intercalate " -> " (reifyTest p) + +-------------------------------------------------------------------------------- +-- Example +-------------------------------------------------------------------------------- + +-- a -> a -> Char -> b (user view) +-- Int -> Int -> Char -> Bool (test view) +type Example = '[ Poly 0 Int, Poly 0 Int, Fixed Char, Poly 1 Bool ] + +-- Uncomment to see compile error: +-- type Bad = '[ Poly 0 Int, Poly 0 Bool, Poly 1 Bool ] diff --git a/src/RunGhc/SystemModule.hs b/src/RunGhc/SystemModule.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/SystemModule.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} +module RunGhc.SystemModule where + +import RunGhc.Locate +import Data.Aeson +import GHC.Generics +import qualified Data.Text as T + +-- We locate at the latest possible step, for flexibility +-- +-- NOTE that partial-modules written by the user are still +-- a SystemModule as we are the builder +data SystemModule + = ExpressionsOnly Expressions + | ExpressionsImportsOnly Imports Expressions + | ExpressionsImportsExtensionsOnly Extensions Imports Expressions + deriving Generic + -- todo: as Semigroup +instance ToJSON SystemModule +instance FromJSON SystemModule + +instance Semigroup SystemModule where + a <> b = + ExpressionsImportsExtensionsOnly + (askExtensions a <> askExtensions b) + (askImports a <> askImports b) + (askExpressions a <> askExpressions b) + -- -- case (a,b) of + -- -- (ExpressionsOnly + -- ExpressionsOnly expr <> + -- | ExpressionsImportsOnly Imports Expressions + -- | ExpressionsImportsExtensionsOnly Extensions Imports Expressions + +type FunctionName = T.Text + +askExpressions :: SystemModule -> Expressions +askExpressions = \case + ExpressionsOnly e -> e + ExpressionsImportsOnly _ e -> e + ExpressionsImportsExtensionsOnly _ _ e -> e +askImports :: SystemModule -> Imports +askImports = \case + ExpressionsOnly _ -> mempty + ExpressionsImportsOnly i _ -> i + ExpressionsImportsExtensionsOnly _ i _ -> i +askExtensions :: SystemModule -> Extensions +askExtensions = \case + ExpressionsOnly _ -> mempty + ExpressionsImportsOnly _ _ -> mempty + ExpressionsImportsExtensionsOnly exts _ _ -> exts + +-- showImportLine :: Import -> T.Text +-- showImportLine imp = case _import_qualifiedName imp of +-- Nothing -> +-- "import " <> pathSegsToModuleName (_import_pathSeg imp) <> "\n" +-- Just qName -> +-- "import qualified " +-- <> pathSegsToModuleName (_import_pathSeg imp) +-- <> " as " +-- <> qName +-- <> "\n" + +class SemigroupModule a where + addImports :: Imports -> a -> a + addExtensions :: Extensions -> a -> a + addFuncsDataDecls :: Expressions -> a -> a + +instance SemigroupModule SystemModule where + addImports = addImportsSystemModule + addExtensions = addExtensionsSystemModule + addFuncsDataDecls = addExpressionSource + +addExtensionsSystemModule :: Extensions -> SystemModule -> SystemModule +addExtensionsSystemModule exts = \case + ExpressionsOnly expr -> + ExpressionsImportsExtensionsOnly exts (Imports []) expr + ExpressionsImportsOnly importList expr -> + ExpressionsImportsExtensionsOnly exts importList expr + ExpressionsImportsExtensionsOnly exts1 importList expr -> + ExpressionsImportsExtensionsOnly (exts1 <> exts) importList expr + +addImportsSystemModule :: Imports -> SystemModule -> SystemModule +addImportsSystemModule imports = \case + ExpressionsOnly expr -> + ExpressionsImportsOnly imports expr + ExpressionsImportsOnly importList expr -> + ExpressionsImportsOnly (imports <> importList) expr + ExpressionsImportsExtensionsOnly extensions importList expr -> + ExpressionsImportsExtensionsOnly extensions (imports <> importList) expr + + +addExpressionSource :: Expressions -> SystemModule -> SystemModule +addExpressionSource (Expressions txt2) = \case + ExpressionsOnly (Expressions txt1) -> + ExpressionsOnly (Expressions $ txt1 <> txt2) + ExpressionsImportsOnly importList (Expressions txt1) -> + ExpressionsImportsOnly importList (Expressions $ txt1 <> txt2) + ExpressionsImportsExtensionsOnly extensions importList (Expressions txt1) -> + ExpressionsImportsExtensionsOnly extensions importList (Expressions $ txt1 <> txt2) + + +newtype Expressions = Expressions { getExpressions :: T.Text } + deriving (Show, Generic) +newtype Extensions = Extensions { getExtensions :: [T.Text] } + deriving (Show, Generic) +instance ToJSON Expressions +instance FromJSON Expressions +instance ToJSON Extensions +instance FromJSON Extensions + + +instance Semigroup Extensions where + Extensions a <> Extensions b = Extensions $ a <> b +instance Monoid Extensions where + mempty = Extensions mempty +instance Semigroup Expressions where + Expressions a <> Expressions b = Expressions $ a <> b + diff --git a/src/RunGhc/TrivialBuilders.hs b/src/RunGhc/TrivialBuilders.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/TrivialBuilders.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} + +module RunGhc.TrivialBuilders where + +import RunGhc.LocatedModule +import RunGhc.Locate +import RunGhc.SystemModule +import RunGhc.MakeExe +import RunGhc.Executable +import RunGhc.UserInput +import Data.Default +import qualified Data.Text as T + + + +withF + :: FunctionName + -> (FunctionName -> Script) + -> T.Text + -> Either T.Text Executable +withF fname mkScript userScript = + Right $ toExe userModule testScript + where + userModule = mkUserModule' settings_ userScript + testScript = LocatedTestModule $ locate [PathSegment "Main"] $ mkScript fname + settings_ = def +runF :: FunctionName -> T.Text -> Either T.Text Executable +runF fname userScript = + Right $ toExe userModule testScript + where + userModule = mkUserModule' settings_ userScript + testScript = simpleExeFromFunctionNameAsLib fname (getLocatedUserModule userModule) + settings_ = def +runMain :: T.Text -> Either T.Text Executable +runMain = runF "main" + +runMainHs :: T.Text -> Either T.Text Executable +runMainHs = Right . toSingleModuleExe . locate [PathSegment "Main"] . Script + +-- | Interesting way to do it, but we need a way for the Executable +-- to instruct how it should be run (SAFELY!) +-- runModuleNameHs :: T.Text -> Either T.Text Executable +-- runModuleNameHs = Right . toSingleModuleExe . locate [PathSegment "Main"] . Script + + +withSymbols + :: Qualifiable args + => args + -> (args -> Script) + -> T.Text + -> Either T.Text Executable +withSymbols symbols mkScript userScript = + Right $ toExe userModule testScript + where + userModule = mkUserModule' settings_ userScript + testScript = LocatedTestModule $ locate [PathSegment "Main"] $ mkScript symbols + settings_ = def + +mkSelfTestedExecutable :: LocatedUserModule -> Executable +mkSelfTestedExecutable (LocatedUserModule loc) = mkExecutableNoLibrary loc + + +mkExecutableNoLibrary :: LocatedModule -> Executable +mkExecutableNoLibrary loc = Executable loc [] + +mkUserExecutableNoLibrary :: LocatedUserModule -> Executable +mkUserExecutableNoLibrary (LocatedUserModule loc) = Executable loc [] + +addUserLibraryToExecutableQualified :: T.Text -> LocatedUserModule -> Executable -> Executable +addUserLibraryToExecutableQualified qname (LocatedUserModule loc) exe = + Executable + (addImports (Imports [toQualifiedImport qname $ getPathSegments loc]) (_main exe)) + [loc] + +-- Assumes user script at UserModule.hs and testing script at Main.hs +-- This is useful as sometimes we want to allow the user and tester +-- to write arbitrary scripts. Although we as the tester, should heavily rely on the Expression builders +unsafeMkExecutable :: Script -> Script -> Executable +unsafeMkExecutable userScript testScript = + Executable + (FromLocatedScript (LocatedScript [PathSegment "Main"] testScript)) + [(FromLocatedScript (LocatedScript [PathSegment "UserModule"] userScript)) + ] +--unsafeMkExecutable = +newtype ImportName = ImportName T.Text + +mkSimpleExecutable + :: ImportName + -> LocatedUserModule + -> LocatedMainModule + -> Executable +mkSimpleExecutable (ImportName qname) (locUser) (LocatedMainModule locMain) = + addUserLibraryToExecutableQualified qname locUser $ mkExecutableNoLibrary locMain + +asIs :: Script -> Executable +asIs scr = + Executable + { _main = FromLocatedScript $ LocatedScript [PathSegment "Main"] scr + , _library = [] + } + +-- There is no option for the user +-- to submit a partial file, and main is assumed to exist +asLibWithMain :: T.Text -> (LocatedUserModule, Bool) +asLibWithMain txt = + (,True) -- that main exists + $ LocatedUserModule + $ locate [PathSegment "UserLibrary"] + $ Script txt + +-- There is no option for the user +-- to submit a partial file, and main is assumed to exist +asExpressionsWithMain :: T.Text -> (LocatedUserModule, Bool) +asExpressionsWithMain txt = + (,True) -- that main exists + $ LocatedUserModule + $ locate [PathSegment "UserLibrary"] + $ ExpressionsOnly $ Expressions txt + +mkCommonExecutable :: CommonExe -> Executable +mkCommonExecutable = undefined + +data CommonExe + = SimpleUserScript Script -- is main, with maybe some actions + -- ^ Run as main + | TestedUserExpression Expressions SystemModule + -- ^ User expression , our test + | TestedUserScript Script SystemModule + -- ^ User script , our test + | TestedLocatedUserScript LocatedScript SystemModule + -- ^ User located script , our test + --- | forall a. Locatable a => Tested a SystemModule + | UserProject LocatedModule [LocatedModule] + -- ^ Main , Library + --- | TestedUserProject LocatedTestModule LocatedUserModule [LocatedModule] + -- likely gonna be a special type of test we write but not necessarily + -- linkably different + +--- Put in new module? --------------------------------------------------------- + diff --git a/src/RunGhc/UserInput.hs b/src/RunGhc/UserInput.hs new file mode 100644 --- /dev/null +++ b/src/RunGhc/UserInput.hs @@ -0,0 +1,488 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} +module RunGhc.UserInput where + +{- +A collection of helper functions for providing something our API can understand which is ultimately just the Executable type +-} + +import Scrappy.Scrape +import Text.Parsec +import RunGhc.Executable +import RunGhc.LocatedModule +import RunGhc.Locate +import RunGhc.SystemModule +import Data.Bifunctor +import Text.IStr +import Data.Default +import qualified Data.Text as T +import Data.Char (toUpper, toLower) + +data UserModuleSettings = UserModuleSettings + { _location :: [PathSegment] + , _allowImports :: Bool + , _overrideMake_If_main_exists :: Bool + , _mkSystemModule :: Expressions -> SystemModule + } +instance Default UserModuleSettings where + def = UserModuleSettings + { _location = [PathSegment "UserModule"] + , _allowImports = True + , _overrideMake_If_main_exists = False + , _mkSystemModule = ExpressionsOnly + } + +mkUserModule' :: UserModuleSettings -> T.Text -> LocatedUserModule +mkUserModule' cfg input = + LocatedUserModule $ mkUserModule + (_location cfg) + (_allowImports cfg) + (_overrideMake_If_main_exists cfg) + (_mkSystemModule cfg) + input + +handleUserInputMultipleFiles :: (FilePath, Script) -> [(FilePath, T.Text)] -> Executable +handleUserInputMultipleFiles main@(targetPath, Script mainSrc) txtsWithPath = + let + f (fp, script) = + FromLocatedScript $ LocatedScript (pathSegsFromFilePath fp) $ Script script + fMain (fp, Script script) = + FromLocatedScript $ LocatedScript (pathSegsFromFilePath fp) $ Script script + in + Executable (fMain main) (f <$> txtsWithPath) + +-- tryHandleUserInput +parseUserScript + :: T.Text -- Raw user input + -> Bool -- can contain imports? + -> Bool -- can contain main? + -> Either Script Expressions +parseUserScript txt canContainImports cancelWhenMainExists = + let + moduleHeadPieces = findModuleHeadPieces txt + mainExists = exists mainFuncParser $ T.unpack txt -- (string "main :: IO ()" + x = case moduleHeadPieces of + Just _ -> Left $ Script txt + Nothing -> Right $ Expressions txt + + in case moduleHeadPieces of + Just _ -> + -- We cannot interact with this script + Left $ Script txt + Nothing -> + case mainExists && cancelWhenMainExists of + True -> Left $ Script txt + False -> Right $ Expressions txt + +handleUserInputSingleFile + :: T.Text + -> LocatedUserModule +handleUserInputSingleFile txt = + LocatedUserModule + $ FromLocatedScript + $ LocatedScript [PathSegment "UserLibrary"] + $ Script txt + + +-- We only build if they gave just an Expressions +unsafeMkSystemModuleFromExpressionsOnly + :: Expressions + -> Imports + -> Extensions + -> SystemModule +unsafeMkSystemModuleFromExpressionsOnly exprs imports extensions = + -- LocatedUserModule + -- FromSystemModuele [PathSegment "UserLibrary"] + addExtensions extensions + $ addImports imports + $ ExpressionsOnly + $ exprs + +-- Super naive function +unsafeMkLocatedUserModule + :: Expressions + -> LocatedUserModule +unsafeMkLocatedUserModule expr = + LocatedUserModule + $ FromSystemModule [PathSegment "UserLibrary"] + $ ExpressionsOnly + $ expr + +(<+>) :: Applicative m => m a -> m b -> m (a, b) +ma <+> mb = (,) <$> ma <*> mb + + +-- 99% of cases are +-- Text -> LocatedUserModule +-- + + +-- We should also have functionality to check if the Module exports main + +-- case exportsMain { True -> Exe ; False -> Library } +-- ; +-- A general theme i am noticing is that if we want user freedom -> their code is Main.main (eg user playground/ first program) +-- but if we need to give any feedback or interaction at all, then their code +-- must be under .* (eg. Hackerrank style, large projects, chapter exercises) +-- +-- Otherwise, even if they give main we should still write Main.hs ourselves. Why? +-- - We may need to affect the environment, which is actually more likely if they give `main :: IO ()` + +-- We either have just an expression or something more +-- but either way we are trying to normalize it + +-- Note that on a LocatedModule we should always be able to apply +-- a function (f :: SystemModule -> SystemModule) and if it is actually +-- a LocatedScript then we do nothing +-- f `apply` lMod = lMod ; when lMod is lScript +-- tryHandleUserInputExpressionsOnly +-- :: T.Text +-- -- ^ User Input direct +-- -> Imports +-- -- ^ Configured imports +-- -> Extensions +-- -- ^ ConfiguredExtensions +-- -> (LocatedUserModule, Bool) -- or is this unlocated??? +-- tryHandleUserInputExpressionsOnly txt imports extensions = +-- let +-- locate_ :: forall a. Locatable a => a -> LocatedModule +-- locate_ = locate [PathSegment "UserLibrary"] +-- moduleHeadPieces = findModuleHeadPieces txt +-- mainExists = exists mainFuncParser $ T.unpack txt -- (string "main :: IO ()" +-- in +-- (,mainExists) +-- $ LocatedUserModule +-- $ case moduleHeadPieces of +-- Just ("module":"where":xs) -> locate_ $ Script txt +-- Just xs | "import" `elem` xs -> locate_ $ Script txt +-- Just something -> locate_ $ Script txt +-- Nothing -> +-- locate_ +-- $ addExtensions extensions +-- $ addImports imports +-- $ ExpressionsOnly $ Expressions txt + -- is as expected a function or set of functions and types + --FromSystemModule ["UserLibrary"] $ ExpressionsOnly + +-- the theoretical reason why existence of main, may matter is that +-- in some cases, we want to allow that to override the mkExe logic +-- +-- In those cases, if `main` exists then we should (give option to) avoid mkModule + -- this would most likely be when main is not in Symbols expected by Test script + +-- ( importsExist @Bool -> mainExists @Bool -> choice_runMkModule @Bool ) + -- implicitly the existence of Main or Extensions |absolutely| negates + -- any user choices + +-- x :: LocatedModule +-- x = +-- -- either id id +-- -- $ bimap +-- -- (locate pathSegs) +-- fromLocatableSource [PathSegment "UserModule"] +-- $ +-- (fmap mkLocatedUserModule :: SystemModule -> SystemModule) --LocatedModule) +-- $ tryHandleUserInput "input" + + +--f :: Bool -> Bool -> (SystemModule -> SystemModule) -> T.Text -> LocatedModule + +--TODO: system module + +-- wouldnt it always be an Expressions type? + +-- TODO: give module name as string arg +mkUserModule + :: [PathSegment] -- location + -> Bool -- allow imports? + -> Bool -- main exists? + -> (Expressions -> SystemModule) -- mkModule (eg addImports, addExts, ...) + -> T.Text -- User input + -> LocatedModule +mkUserModule pathSegs allowImports mainExists mutModule input = + locateUserSource pathSegs + $ fmap mutModule + $ parseUserScript input allowImports mainExists + +-- Handle if user wrote their own full module, +-- or if we can make a SystemModule freely +locateUserSource + :: [PathSegment] + -> Either Script SystemModule + -> LocatedModule +locateUserSource pathSegs userScript = + either id id + $ bimap + (locate pathSegs) + (locate pathSegs) + userScript + + -- case targetPath `List.lookup` $ txtsWithPath of + -- Nothing + -- f <$> (main : txtsWithPath) + --FromLocatedScript $ LocatedScript ["UserLibrary"] $ Script txt + + +--- Parsers used for scraping + analysis + +caseInsensitiveString + :: forall s u m + . Stream s m Char + => String + -> ParsecT s u m String +caseInsensitiveString s = do + let + f :: Stream s m Char => Char -> ParsecT s u m Char + f chr = char (toUpper chr) <|> char (toLower chr) + --fs = f <$> s + mapM f s + + +mainFuncParser :: Stream s m Char => ParsecT s u m () +mainFuncParser = try a <|> b + where + a = do + _ <- string "main" + _ <- many space + _ <- string "::" + _ <- many space + _ <- string "IO" + _ <- many space + _ <- string "()" + pure () + b = do + _ <- string "main" + _ <- many space + _ <- string "=" + pure () + + +findModuleHeadPieces :: T.Text -> Maybe [String] +findModuleHeadPieces txt = scrape moduleHeadPiece $ T.unpack txt + +moduleHeadPiece :: Stream s m Char => ParsecT s u m String +moduleHeadPiece = do + try (string "module") + <|> try (string "where") + <|> string "import" + <|> ( string "{-#" + >> many space + >> caseInsensitiveString "language" + ) + -- or if there exists import + + + + + -- \case + -- _ + +-- -- attachLibraryToUserModule :: LocatedUserModule -> Located-> [LocatedModule] -> Executable +-- -- attachLibraryToUserModule +-- addUserLibraryToExecutable :: LocatedUserModule -> Executable -> Executable +-- addUserLibraryToExecutable (LocatedUserModule loc) exe = Executable (addImports (Imports [toSimpleImport $ getPathSegments loc]) (_main exe)) [loc] + + +-- addSystemLibraryToExecutable :: LocatedTestModule -> Executable -> Executable +-- addSystemLibraryToExecutable locs exe = Executable (_main exe) $ locs : (_library exe) + +-- mkUserExecutableNoLibrary :: LocatedUserModule -> Executable +-- mkUserExecutableNoLibrary (LocatedUserModule loc) = Executable loc [] +-- run the user script 'as is' with zero processing + +-- we want the writer of the script to pass the qualified name + +-- test_1Input :: FunctionName -> Expression -> Expressions +-- test_1Input fname (Expression expr) = Expressions $ fname <> " " <> expr + +-- test_card1 :: FunctionName -> Expression -> Expressions + +-- test_card2 :: FunctionName -> Expression -> Expression -> Expressions + +-- test_card2 :: FunctionName -> Expression -> Expression -> Expressions + + +-- testThisFunction +-- :: FunctionName +-- -> Expression +-- -> Executable + + + +-- fromDependentSystemModule +-- :: Qualifiable a +-- => [PathSegment] +-- -> Imports +-- -> Extensions +-- -> a -- FunctionName for instance +-- -> LocatedModule -- The user module +-- -> SystemModule +-- -> LocatedModule +-- fromDependentSystemModule pathLoc imps exts symbols userModule sysModule = +-- addExtensions exts +-- $ addImports (Imports [localQualifiedImport "UserModule" userModule]) +-- $ addImports imps +-- $ FromSystemModule pathLoc sysModule +-- + --- $ ExpressionsOnly $ withF (qualify "UserModule" symbols) +-- fromDependentSystemModule' +-- :: Qualifiable a +-- => [PathSegment] +-- -> a -- FunctionName for instance +-- -> LocatedModule -- The user module +-- -> SystemModule +-- -> LocatedModule +-- fromDependentSystemModule' pathLoc symbols userModule sysModule = +-- addImports (Imports [localQualifiedImport "UserModule" userModule]) +-- $ FromSystemModule pathLoc sysModule +-- | TODO: +-- +-- instead this adding of localQualifiedImport +-- should be during a system module creation +-- + + + + +-- let secondLine = +-- if "main :: IO ()" `isInfixOf` userMod +-- then \f -> f -- "#{f}" +-- else \f -> "mapM_ (print . " <> f <> ") $ toColor [1..10]" +-- (\f -> [istr| +-- main :: IO () +-- main = do +-- setupEnv +-- (#{secondLine hasMain f}) +-- --mapM_ (print . #{f}) $ toColor [1..10] +-- runChecks + + +-- data Color = Red | Blue | Green | Orange | Violet | Black | Gold deriving (Eq, Ord, Enum) + +-- toColor = fromEnum +-- |] + +-- ) + + + + +-- chooseTestScriptBuild +-- :: (LocatedUserModule, Bool) +-- -> (LocatedUserModule -> symbols -> (symbols -> Expressions)) +-- -> Expressions +-- -> LocatedTestModule +-- chooseTestScriptBuild (userModule, hasMain) whenNoMain whenMain = undefined + + + + +-- setup +-- run Either Main (MkScript :: symbols -> Expressions) +-- Value-based tests + + + -- mkMainExeWithDefaultHead user "main" $ \main_ -> + -- Expressions $ [istr| main = #{main_} |] + + +-- if they gave a UserModule.main :: IO () , specifically "main :: IO ()" exists +-- then write the environment? with bracket + +-- bracket f (setupEnv) (reportBenchmarks) + + +-- bracket UserModule.main setupEnv (runEqualityChecks <+> runBenchmarks) + + + -- makeTestScriptWithImportsExtensions + -- [PathSegment "Main"] + -- (fst $ defaultHeadMainModule) + -- (snd $ defaultHeadMainModule) + -- symbols + -- userModule + -- mkExpr + + +-- mk userModule = makeTestScriptWithImportsExtensions +-- [PathSegment "Main"] +-- mempty +-- mempty +-- (Symbol "f", Symbol "g", Symbol "Maybee") +-- userModule +-- (\(Symbol fname, Symbol gname, Symbol typeName) -> [istr|main = #{gname} @#{typeName} $ #{fname} <$> [1..10]|]) + +-- mk2 userModule = makeTestScriptWithImportsExtensions +-- [PathSegment "Main"] +-- (Imports [ Import (Just "T") ["Data", "Text"] +-- , Import (Just "Json") ["Data", "Aeson"] +-- ]) +-- (Extensions ["OverloadedStrings"]) +-- "f" +-- -- In theory we could pass a reftype +-- userModule +-- (\fname -> [istr| +-- main = #{fname} <$> (fmap T.show [1..10]) +-- |] <> dataTypeExists "Maybee") + + +-- makeTestScriptWithDefaultHead_1ref +-- :: LocatedModule -- The user module +-- -> Symbol +-- -> (FunctionName -> Expressions) +-- -> LocatedModule +-- makeTestScriptWithDefaultHead userModule fname symbol mkExpr = + +-- makeTestScriptWithDefaultHead_1ref +-- :: LocatedModule -- The user module +-- -> Symbol +-- -> (FunctionName -> Expressions) +-- -> LocatedModule +-- makeTestScriptWithDefaultHead_1ref userModule fname symbol mkExpr = + +-- makeTestScriptWithDefaultHead_2ref +-- :: LocatedModule -- The user module +-- -> FunctionName +-- -> (Symbol, Symbol) +-- -> ((Symbol, Symbol) -> Expressions) +-- -> LocatedModule +-- makeTestScriptWithDefaultHead_2ref userModule (symbol1, symbol2) mkExpr = +-- let (imports, exts) = defaultHeadMainModule +-- in makeTestScriptWithImportsExtensions +-- [PathSegment "Main"] +-- imports +-- exts +-- (symbol1, symbol2) +-- userModule +-- mkExpr + +-- -- [istr| + +-- |] +-- [istr| +-- module Main where +-- #{importLine} +-- main = #{qname}.#{fname} +-- |] + + + +-- mkUserExecutableAsLibrary +-- :: LocatedUserModule +-- -> Executable +-- mkUserExecutableAsLibrary (LocatedUserModule loc) = Executable (mod qname_) [loc] +-- where +-- qname_ = "UserModule" +-- importLine = showImportLine $ localQualifiedImport qname loc --Import Nothing [getPathSegments loc +-- mod qname = FromLocatedScript $ LocatedScript [PathSegment "Main"] $ Script +-- --"" +-- $ [istr| +-- module Main where +-- #{importLine} +-- main = #{qname}.main + +-- |]