Skip to content

Commit

Permalink
Address all ghc pedantic warnings (test and src)
Browse files Browse the repository at this point in the history
  • Loading branch information
arendsee committed Mar 2, 2024
1 parent 6ff686d commit 1919f7a
Show file tree
Hide file tree
Showing 7 changed files with 50 additions and 23 deletions.
1 change: 0 additions & 1 deletion executable/Subcommands.hs
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,6 @@ import qualified Morloc.Data.Text as MT
import qualified Morloc.Module as Mod
import qualified Morloc.Monad as MM
import qualified Morloc.Frontend.API as F
import qualified Morloc.Data.GMap as GMap
import Morloc.CodeGenerator.Namespace (SerialManifold(..))
import Morloc.CodeGenerator.Grammars.Translator.PseudoCode (pseudocodeSerialManifold)
import Morloc.Data.Doc
Expand Down
14 changes: 9 additions & 5 deletions library/Morloc/Frontend/Classify.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,10 @@ import Morloc.Frontend.Merge (weaveTermTypes, mergeTypeclasses, mergeSignatureSe


-- Merge two indexed instances keeping the left index
mergeIndexedInstances
:: Indexed Instance
-> Indexed Instance
-> MorlocMonad (Indexed Instance)
mergeIndexedInstances = mergeFirstIndexM mergeTypeclasses

-- Handle typeclasses
Expand Down Expand Up @@ -308,22 +312,22 @@ same as the `a` and `b` in the class.
-}
substituteInstanceTypes :: [TVar] -> TypeU -> [TypeU] -> MorlocMonad TypeU
substituteInstanceTypes classVars classType instanceParameters = do
substituteInstanceTypes clsVars clsType instanceParameters = do

-- find all qualifiers in the instance parameter list
let instanceQualifiers = unique $ concatMap (fst . unqualify) instanceParameters

-- rewrite the class type such that the class qualifiers appear first and
-- do not conflict with parameter qualifiers
cleanClassType = replaceQualifiers instanceQualifiers (putClassVarsFirst classType)
cleanClassType = replaceQualifiers instanceQualifiers (putClassVarsFirst clsType)

-- substitute in the parameter types
finalType = qualify instanceQualifiers
$ substituteQualifiers cleanClassType (map (snd . unqualify) instanceParameters)

MM.sayVVV $ "substituteInstanceTypes"
<> "\n classVars:" <+> pretty classVars
<> "\n classType:" <+> pretty classType
<> "\n classVars:" <+> pretty clsVars
<> "\n classType:" <+> pretty clsType
<> "\n instanceParameters:" <+> pretty instanceParameters
<> "\n -------------------"
<> "\n instanceQualifiers:" <+> pretty instanceQualifiers
Expand All @@ -336,7 +340,7 @@ substituteInstanceTypes classVars classType instanceParameters = do
putClassVarsFirst :: TypeU -> TypeU
putClassVarsFirst t =
let (vs, t') = unqualify t
in qualify (classVars <> filter (`notElem` classVars) vs) t'
in qualify (clsVars <> filter (`notElem` clsVars) vs) t'

replaceQualifiers :: [TVar] -> TypeU -> TypeU
replaceQualifiers vs0 t0 = f vs0 [r | r <- freshVariables, r `notElem` doNotUse] t0
Expand Down
4 changes: 2 additions & 2 deletions library/Morloc/Typecheck/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -522,11 +522,11 @@ renameSExpr c0@(m, g) e0 = case e0 of
(VarS v (MonomorphicExpr t xs)) ->
let (context', xs') = statefulMap renameAnnoS c0 xs
in (context', VarS v (MonomorphicExpr t xs'))
(VarS v (PolymorphicExpr cls className t rs)) ->
(VarS v (PolymorphicExpr cls clsName t rs)) ->
let (ts, ass) = unzip rs
(context', ass') = statefulMap (statefulMap renameAnnoS) c0 ass
rs' = zip ts ass'
in (context', VarS v $ PolymorphicExpr cls className t rs')
in (context', VarS v $ PolymorphicExpr cls clsName t rs')
(LamS vs x) ->
let (g', vs') = statefulMap (\g'' (EV v) -> evarname g'' (v <> "_e")) g vs
m' = foldr (uncurry Map.insert) m (zip vs vs')
Expand Down
2 changes: 1 addition & 1 deletion test-suite/GoldenMakefileTests.hs
Original file line number Diff line number Diff line change
Expand Up @@ -24,7 +24,7 @@ makeManifoldFile :: String -> IO ()
makeManifoldFile path = do
abspath <- SD.makeAbsolute path
devnull <- SI.openFile "/dev/null" SI.WriteMode
SP.runProcess
_ <- SP.runProcess
"make" -- command
["-C", abspath, "--quiet"] -- arguments
Nothing -- optional path to working diretory
Expand Down
1 change: 1 addition & 0 deletions test-suite/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,7 @@ import PropertyTests (propertyTests)
import UnitTypeTests
import GoldenMakefileTests (goldenMakefileTest)

main :: IO ()
main = do
wd <- SD.getCurrentDirectory >>= SD.makeAbsolute
let golden = \msg f -> goldenMakefileTest msg (wd ++ "/test-suite/golden-tests/" ++ f)
Expand Down
5 changes: 1 addition & 4 deletions test-suite/PropertyTests.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,14 +4,11 @@ module PropertyTests

import Morloc.Namespace

import qualified Control.Monad as CM
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Test.QuickCheck as QC
import Safe (headMay)
import Test.Tasty
import Test.Tasty.QuickCheck as TQC

propertyTests :: TestTree
propertyTests =
testGroup
"internal list function properties"
Expand Down
46 changes: 36 additions & 10 deletions test-suite/UnitTypeTests.hs
Original file line number Diff line number Diff line change
Expand Up @@ -34,6 +34,7 @@ runFront code = do
((x, _), _) <- MM.runMorlocMonad Nothing 0 emptyConfig (typecheckFrontend Nothing (Code code) >>= mapM evaluateAnnoSTypes)
return x

emptyConfig :: Config
emptyConfig = Config
{ configHome = ""
, configLibrary = ""
Expand All @@ -54,7 +55,7 @@ assertGeneralType msg code t = testCase msg $ do
"The following error was raised: " <> show e <> "\nin:\n" <> show code

renameExistentials :: TypeU -> TypeU
renameExistentials = snd . f (0, Map.empty) where
renameExistentials = snd . f (0 :: Int, Map.empty) where
f s (VarU v) = (s, VarU v)
f (i,m) (ExistU v ps rs) =
case Map.lookup v m of
Expand Down Expand Up @@ -86,7 +87,7 @@ assertSubtypeGamma :: String -> [GammaIndex] -> TypeU -> TypeU -> [GammaIndex] -
assertSubtypeGamma msg gs1 a b gs2 = testCase msg $ do
let g0 = Gamma {gammaCounter = 0, gammaContext = gs1}
case MTI.subtype a b g0 of
Left err -> error $ show err
Left e -> error $ show e
Right (Gamma _ gs2') -> assertEqual "" gs2 gs2'

exprTestBad :: String -> MT.Text -> TestTree
Expand Down Expand Up @@ -119,29 +120,47 @@ testFalse :: String -> Bool -> TestTree
testFalse msg x =
testCase msg $ assertEqual "" x False

bool :: TypeU
bool = VarU (TV "Bool")

real :: TypeU
real = VarU (TV "Real")

int :: TypeU
int = VarU (TV "Int")

str :: TypeU
str = VarU (TV "Str")

fun :: [TypeU] -> TypeU
fun [] = error "Cannot infer type of empty list"
fun [t] = FunU [] t
fun ts = FunU (init ts) (last ts)

forall [] t = t
forall (s:ss) t = ForallU (TV s) (forall ss t)
forall :: [MT.Text] -> TypeU -> TypeU
forall ss t = foldr (ForallU . TV) t ss

exist :: MT.Text -> TypeU
exist v = ExistU (TV v) [] []

var :: MT.Text -> TypeU
var s = VarU (TV s)
arr s ts = AppU (VarU (TV s)) ts

arr :: MT.Text -> [TypeU] -> TypeU
arr s = AppU (VarU (TV s))

lst :: TypeU -> TypeU
lst t = arr "List" [t]

tuple :: [TypeU] -> TypeU
tuple ts = AppU v ts
where
v = VarU . TV . MT.pack $ "Tuple" ++ show (length ts)
record rs = NamU NamRecord (TV "Record") [] rs
record' n rs = NamU NamRecord (TV n) [] rs

record' :: MT.Text -> [(Key, TypeU)] -> TypeU
record' n = NamU NamRecord (TV n) []

subtypeTests :: TestTree
subtypeTests =
testGroup
"Test subtype within context"
Expand Down Expand Up @@ -188,9 +207,8 @@ subtypeTests =
edg = ExistG (TV "x4") [] []
solvedA t = SolvedG (TV "x1") t
solvedB t = SolvedG (TV "x2") t
solvedC t = SolvedG (TV "x3") t
solvedD t = SolvedG (TV "x4") t

substituteTVarTests :: TestTree
substituteTVarTests =
testGroup
"test variable substitution"
Expand All @@ -199,6 +217,7 @@ substituteTVarTests =
(fun [lst (var "y"), var "y"])
]

whitespaceTests :: TestTree
whitespaceTests =
testGroup
"Tests whitespace handling for modules"
Expand Down Expand Up @@ -243,6 +262,7 @@ module Main (z)
int
]

recordAccessTests :: TestTree
recordAccessTests =
testGroup
"Test record access"
Expand Down Expand Up @@ -276,11 +296,13 @@ recordAccessTests =
(tuple [int, str])
]

packerTests :: TestTree
packerTests =
testGroup
"Test building of packer maps"
[ testEqual "packer test" 1 1 ]
[ testEqual "packer test" (1 :: Int) 1 ]

typeAliasTests :: TestTree
typeAliasTests =
testGroup
"Test type alias substitutions"
Expand Down Expand Up @@ -513,6 +535,7 @@ typeAliasTests =
]


whereTests :: TestTree
whereTests =
testGroup
"Test of where statements"
Expand Down Expand Up @@ -549,6 +572,7 @@ whereTests =
]


orderInvarianceTests :: TestTree
orderInvarianceTests =
testGroup
"Test order invariance"
Expand All @@ -566,6 +590,7 @@ orderInvarianceTests =
int
]

typeOrderTests :: TestTree
typeOrderTests =
testGroup
"Tests of type partial ordering (subtype)"
Expand Down Expand Up @@ -693,6 +718,7 @@ typeOrderTests =
[forall ["a"] (tuple [int, var "a"])]
]

unitTypeTests :: TestTree
unitTypeTests =
testGroup
"Typechecker unit tests"
Expand Down

0 comments on commit 1919f7a

Please sign in to comment.