carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-11 05:25:28 +03:00
Code Issues Projects Releases Wiki Activity

All tests run, but can still confuse the type checker, see "expression_problem.carp"

Browse Source
This commit is contained in:
Erik Svedäng 2017-11-27 12:36:17 +01:00
parent 2dca5b80bd
commit 7b5a0aa7eb
14 changed files with 118 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/Double.carp
View File

@ -51,5 +51,5 @@
(< (- y x) 0.00001)))
(defn /= [x y]
(not (= x y)))
(not (Double.= x y)))
)

2
core/Float.carp
View File

@ -12,7 +12,7 @@
(register = (Fn [Float Float] Bool))
(defn /= [x y]
(not (= x y)))
(not (Float.= x y)))
(register < (Fn [Float Float] Bool))
(register > (Fn [Float Float] Bool))

2
core/Long.carp
View File

@ -18,7 +18,7 @@
(register copy (λ [&Long] Long)) ;; TODO: Should not be needed when refs to value types are auto-converted to non-refs.
(defn /= [x y]
(not (= x y)))
(not (Long.= x y)))
(register safe-add (λ [Long Long (Ref Long)] Bool))
(register safe-sub (λ [Long Long (Ref Long)] Bool))

2
docs/Todo.md
View File

@ -11,6 +11,8 @@
* [0.3] Confusion with interfaces
* When defining /= in terms of = in modules, the type becomes generic. Should it default to the = inside the module instead?
* When one or more of the instances of a interface is generic, the final type becomes generic too
* matching = filter (\(t, s) -> matchingSignature actualType (t, s) && not (typeIsGeneric t)) tysToPathsDict
* [0.3] Error message with refs is wrong, see Constraints.hs:131
## Big Language Features
* [0.3] Allow evaluation of dynamic functions in the REPL and give access to the Commands from dynamic code

9
examples/expression_problem.carp
View File

@ -9,8 +9,14 @@
;; Young is created later
(deftype Young [age Int])
;; (defmodule Confuse
;; (defn = [a b]
;; true))
(defmodule Young
(defn = [y1 y2]
(Int.= (age y1) (age y2)))
(defn /= [y1 y2]
(Int.= (age y1) (age y2))))
;; Now I want to use 'Young.=' in with 'Ur.compare'
@ -19,3 +25,6 @@
(defn main []
(println &(str (f))))
(build)
(run)

20
examples/temp.carp
View File

@ -2,13 +2,23 @@
(use Int)
(use Float)
(use Double)
;; (use Array)
(use Array)
;; (use System)
;; (use String)
;; (use Char)
;; (use Bool)
(defn main []
(do
(println &(str 3.0f))
(println &(str 123))))
;; (defn main []
;; (do
;; (println &(str 3.0f))
;; (println &(str 123))))
(project-set! printAST "true")
(deftype Blah [])
(defmodule Ur
(defn f [x]
(str x)))
(defn main [] (println (ref (str (ref (Ur.f &[1 2 3]))))))

66
src/Concretize.hs
View File

@ -15,9 +15,9 @@ import AssignTypes
import ManageMemory
-- | This function performs two things:
-- 1. Finds out which polymorphic functions that needs to be added to the environment for the calls in the function to work.
-- 2. Changes the name of symbols at call sites so they use the polymorphic name
-- Both of these results are returned in a tuple: (<new xobj>, <dependencies>)
-- | 1. Finds out which polymorphic functions that needs to be added to the environment for the calls in the function to work.
-- | 2. Changes the name of symbols at call sites so they use the polymorphic name
-- | Both of these results are returned in a tuple: (<new xobj>, <dependencies>)
concretizeXObj :: Bool -> TypeEnv -> Env -> [SymPath] -> XObj -> Either TypeError (XObj, [XObj])
concretizeXObj allowAmbiguity typeEnv rootEnv visitedDefinitions root =
case runState (visit rootEnv root) [] of
@ -27,6 +27,7 @@ concretizeXObj allowAmbiguity typeEnv rootEnv visitedDefinitions root =
visit :: Env -> XObj -> State [XObj] (Either TypeError XObj)
visit env xobj@(XObj (Sym _) _ _) = visitSymbol env xobj
visit env xobj@(XObj (MultiSym _ _) _ _) = visitMultiSym env xobj
visit env xobj@(XObj (InterfaceSym _) _ _) = visitInterfaceSym env xobj
visit env (XObj (Lst lst) i t) = do visited <- visitList env lst
return $ do okVisited <- visited
Right (XObj (Lst okVisited) i t)
@ -110,20 +111,16 @@ concretizeXObj allowAmbiguity typeEnv rootEnv visitedDefinitions root =
visitSymbol _ _ = error "Not a symbol."
visitMultiSym :: Env -> XObj -> State [XObj] (Either TypeError XObj)
visitMultiSym env xobj@(XObj (MultiSym originalSymbolName paths_not_needed_anymore) i t) =
visitMultiSym env xobj@(XObj (MultiSym originalSymbolName paths) i t) =
let Just actualType = t
paths = case lookupInEnv (SymPath [] originalSymbolName) (getTypeEnv typeEnv) of
Just (_, Binder (XObj (Lst [XObj (Interface interfaceSignature interfacePaths) _ _, _]) _ _)) ->
interfacePaths
Nothing ->
paths_not_needed_anymore -- TODO: Remove?!
tys = map (typeFromPath env) paths
tysToPathsDict = zip tys paths
in case filter (matchingSignature actualType) tysToPathsDict of
[] ->
if allowAmbiguity
then return (Right xobj)
else return (Left (NoMatchingSignature xobj originalSymbolName actualType tysToPathsDict))
--if allowAmbiguity
--then return (Right xobj)
--else
return (Left (NoMatchingSignature xobj originalSymbolName actualType tysToPathsDict))
[(theType, singlePath)] -> let Just t' = t
fake1 = XObj (Sym (SymPath [] "theType")) Nothing Nothing
fake2 = XObj (Sym (SymPath [] "xobjType")) Nothing Nothing
@ -144,11 +141,50 @@ concretizeXObj allowAmbiguity typeEnv rootEnv visitedDefinitions root =
severalPaths -> if allowAmbiguity
then return (Right xobj)
else return (Left (CantDisambiguate xobj originalSymbolName actualType severalPaths))
where matchingSignature :: Ty -> (Ty, SymPath) -> Bool
matchingSignature tA (tB, _) = areUnifiable tA tB
visitMultiSym _ _ = error "Not a multi symbol."
visitInterfaceSym :: Env -> XObj -> State [XObj] (Either TypeError XObj)
visitInterfaceSym env xobj@(XObj (InterfaceSym name) i t) =
case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder (XObj (Lst [XObj (Interface interfaceSignature interfacePaths) _ _, _]) _ _)) ->
let Just actualType = t
tys = map (typeFromPath env) interfacePaths
tysToPathsDict = zip tys interfacePaths
in case filter (matchingSignature actualType) tysToPathsDict of
[] -> return $ --(trace ("No matching signatures for interface lookup of " ++ name ++ " of type " ++ show actualType ++ " " ++ prettyInfoFromXObj xobj ++ ", options are:\n" ++ joinWith "\n" (map show tysToPathsDict)))
(Right xobj)
[(theType, singlePath)] -> let Just t' = t
fake1 = XObj (Sym (SymPath [] "theType")) Nothing Nothing
fake2 = XObj (Sym (SymPath [] "xobjType")) Nothing Nothing
in case solve [Constraint theType t' fake1 fake2 OrdMultiSym] of
Right mappings ->
let replaced = replaceTyVars mappings t'
normalSymbol = XObj (Sym singlePath) i (Just replaced)
in visitSymbol env $ --(trace ("Disambiguated interface symbol " ++ pretty xobj ++ prettyInfoFromXObj xobj ++ " to " ++ show singlePath ++ " : " ++ show replaced ++ ", options were:\n" ++ joinWith "\n" (map show tysToPathsDict)))
normalSymbol
Left failure@(UnificationFailure _ _) ->
return $ Left (UnificationFailed
(unificationFailure failure)
(unificationMappings failure)
[])
Left (Holes holes) ->
return $ Left (HolesFound holes)
severalPaths ->
return $ --(trace ("Several matching signatures for interface lookup of '" ++ name ++ "' of type " ++ show actualType ++ " " ++ prettyInfoFromXObj xobj ++ ", options are:\n" ++ joinWith "\n" (map show tysToPathsDict) ++ "\n Filtered paths are:\n" ++ (joinWith "\n" (map show severalPaths))))
--(Left (CantDisambiguateInterfaceLookup xobj name interfaceType severalPaths)) -- TODO unnecessary error?
(Right xobj)
Nothing ->
error ("No interface named '" ++ name ++ "' found.")
matchingSignature :: Ty -> (Ty, SymPath) -> Bool
matchingSignature tA (tB, _) =
areUnifiable tA tB
-- matchingNonGenericSignature :: Ty -> (Ty, SymPath) -> Bool
-- matchingNonGenericSignature actualType (t, s) =
-- matchingSignature actualType (t, s) && not (typeIsGeneric t)
-- | Get the type of a symbol at a given path.
typeFromPath :: Env -> SymPath -> Ty
typeFromPath env p =
@ -176,7 +212,7 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
in case assignTypes mappings withNewPath of
Right typed ->
if newPath `elem` visitedDefinitions
then return (withNewPath, [])
then return (trace ("Already visited " ++ show newPath) (withNewPath, []))
else do (concrete, deps) <- concretizeXObj allowAmbiguity typeEnv globalEnv (newPath : visitedDefinitions) typed
managed <- manageMemory typeEnv globalEnv concrete
return (managed, deps)

6
src/Constraints.hs
View File

@ -15,6 +15,7 @@ import Obj
import Types
data ConstraintOrder = OrdNo
| OrdFuncAppArg
| OrdArrHead
| OrdArg
| OrdDefnBody
@ -33,8 +34,8 @@ data ConstraintOrder = OrdNo
| OrdFuncAppVarTy
| OrdArrBetween
| OrdMultiSym
| OrdInterfaceSym
| OrdFuncAppRet
| OrdFuncAppArg
deriving (Show, Ord, Eq)
data Constraint = Constraint Ty Ty XObj XObj ConstraintOrder deriving Eq
@ -49,7 +50,7 @@ data UnificationFailure = UnificationFailure { unificationFailure ::Constraint
deriving (Eq, Show)
instance Show Constraint where
show (Constraint a b _ _ ord) = "{" ++ show a ++ " == " ++ show b ++ " (ord " ++ show ord ++ ")}"
show (Constraint a b xa xb ord) = "{" ++ show a ++ " == " ++ show b ++ " (ord " ++ show ord ++ ")} " ++ show (fmap infoLine (info xa)) ++ ", " ++ show (fmap infoLine (info xb))
-- Finds the symbol with the "lowest name" (first in alphabetical order)
recursiveLookup :: TypeMappings -> String -> Maybe Ty
@ -127,6 +128,7 @@ solveOneInternal mappings constraint =
in solveOneInternal mappings (Constraint a b i1 i2 ord)
-- Ref types
-- TODO: This messes up the error message since the constraint is between non-reffed types so the refs don't show in the error message!!!
Constraint (RefTy a) (RefTy b) _ _ _ ->
let (Constraint _ _ i1 i2 ord) = constraint
in solveOneInternal mappings (Constraint a b i1 i2 ord)

6
src/Emit.hs
View File

@ -25,6 +25,7 @@ data ToCError = InvalidParameter XObj
| CannotEmitModKeyword
| BinderIsMissingType Binder
| UnresolvedMultiSymbol XObj
| UnresolvedInterfaceSymbol XObj
| UnresolvedGenericType XObj
instance Show ToCError where
@ -39,6 +40,9 @@ instance Show ToCError where
"Found ambiguous symbol '" ++ symName ++
"' (alternatives are " ++ joinWithComma (map show symPaths) ++ ")" ++
" at " ++ prettyInfoFromXObj xobj
show (UnresolvedInterfaceSymbol xobj@(XObj (InterfaceSym symName) _ _)) =
"Found unresolved use of interface '" ++ symName ++ "'" ++
" at " ++ prettyInfoFromXObj xobj
show (UnresolvedGenericType xobj@(XObj _ _ (Just t))) =
"Found unresolved generic type '" ++ show t ++ "' at " ++ prettyInfoFromXObj xobj
@ -77,6 +81,7 @@ toC root = emitterSrc (execState (visit 0 root) (EmitterState ""))
e@(Instantiate _) -> error (show (DontVisitObj e))
e@(Defalias _) -> error (show (DontVisitObj e))
e@(MultiSym _ _) -> error (show (DontVisitObj e))
e@(InterfaceSym _) -> error (show (DontVisitObj e))
Address -> error (show (DontVisitObj Address))
SetBang -> error (show (DontVisitObj SetBang))
Macro -> error (show (DontVisitObj Macro))
@ -488,6 +493,7 @@ checkForUnresolvedSymbols = visit
(Lst _) -> visitList xobj
(Arr _) -> visitArray xobj
(MultiSym _ _) -> Left (UnresolvedMultiSymbol xobj)
(InterfaceSym _) -> Left (UnresolvedInterfaceSymbol xobj)
_ -> return ()
visitList :: XObj -> Either ToCError ()

2
src/Infer.hs
View File

@ -45,7 +45,7 @@ annotate typeEnv globalEnv xobj =
annotateOne :: TypeEnv -> Env -> XObj -> Bool -> Either TypeError (XObj, [XObj])
annotateOne typeEnv env xobj allowAmbiguity = do
constraints <- genConstraints xobj
mappings <- solveConstraintsAndConvertErrorIfNeeded constraints
mappings <- solveConstraintsAndConvertErrorIfNeeded constraints --(trace ("CONSTRAINTS:\n" ++ joinWith "\n" (map show constraints)) constraints)
typed <- assignTypes mappings xobj
concretizeXObj allowAmbiguity typeEnv env [] typed

6
src/InitialTypes.hs
View File

@ -69,6 +69,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
(Arr _) -> visitArray env xobj
(Sym symPath) -> visitSymbol env xobj symPath
(MultiSym _ paths) -> visitMultiSym env xobj paths
(InterfaceSym _) -> visitInterfaceSym env xobj
Defn -> return (Left (InvalidObj Defn xobj))
Def -> return (Left (InvalidObj Def xobj))
Let -> return (Left (InvalidObj Let xobj))
@ -108,6 +109,11 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
visitMultiSym :: Env -> XObj -> [SymPath] -> State Integer (Either TypeError XObj)
visitMultiSym _ xobj@(XObj (MultiSym name _) _ _) _ =
do freshTy <- genVarTy
return (Right xobj { ty = Just freshTy })
visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj)
visitInterfaceSym env xobj@(XObj (InterfaceSym name) _ _) =
do freshTy <- case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
Just (_, Binder (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
Just (_, Binder x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ show x)

14
src/Obj.hs
View File

@ -12,7 +12,8 @@ import Debug.Trace
-- | The canonical Lisp object.
data Obj = Sym SymPath
| MultiSym String [SymPath]
| MultiSym String [SymPath] -- refering to multiple functions with the same name
| InterfaceSym String -- refering to an interface. TODO: rename to InterfaceLookupSym?
| Num Ty Double
| Str String
| Chr Char
@ -144,6 +145,7 @@ pretty = visit 0
Chr c -> '\\' : c : ""
Sym path -> show path
MultiSym originalName paths -> originalName ++ "{" ++ joinWithComma (map show paths) ++ "}"
InterfaceSym name -> "(InterfaceSym " ++ name ++ ")"
Bol b -> if b then "true" else "false"
Defn -> "defn"
Def -> "def"
@ -502,21 +504,21 @@ setFullyQualifiedSymbols typeEnv env xobj@(XObj (Sym path) i t) =
case lookupInEnv path env of
Just (foundEnv, _) ->
if envIsExternal foundEnv
then emptyMultiSym name
then createInterfaceSym name
else doesNotBelongToAnInterface
Nothing ->
--trace ("Will turn " ++ show path ++ " into an empty multi sym (found no local symbol with same name)")
emptyMultiSym name
--trace ("Will turn '" ++ show path ++ "' " ++ prettyInfoFromXObj xobj ++ " into an interface symbol.")
createInterfaceSym name
Nothing ->
doesNotBelongToAnInterface
-- Qualified:
_ ->
doesNotBelongToAnInterface
where
emptyMultiSym name = XObj (MultiSym name []) i t -- TODO: Should be it's own kind of Sym maybe?
createInterfaceSym name = XObj (InterfaceSym name) i t
doesNotBelongToAnInterface =
case multiLookupQualified path env of
[] -> xobj
[] -> xobj -- Nothing found, leave the symbol as is
[(_, Binder foundOne)] ->
XObj (Sym (getPath foundOne)) i t
multiple ->

15
src/TypeError.hs
View File

@ -22,6 +22,7 @@ data TypeError = SymbolMissingType XObj Env
| LeadingColon XObj
| UnificationFailed Constraint TypeMappings [Constraint]
| CantDisambiguate XObj String Ty [(Ty, SymPath)]
| CantDisambiguateInterfaceLookup XObj String Ty [(Ty, SymPath)]
| NoMatchingSignature XObj String Ty [(Ty, SymPath)]
| HolesFound [(String, Ty)]
| FailedToExpand XObj EvalError
@ -62,17 +63,25 @@ instance Show TypeError where
show (NoFormsInBody xobj) =
"No expressions in body position at " ++ prettyInfoFromXObj xobj ++ "."
show (UnificationFailed constraint@(Constraint a b aObj bObj _) mappings constraints) =
"Can't unify \n\n" ++ --show aObj ++ " WITH " ++ show bObj ++ "\n\n" ++
" " ++ pretty aObj ++ " : " ++ show (recursiveLookupTy mappings a) ++ "\n " ++ prettyInfoFromXObj aObj ++ "" ++
"Can't unify " ++ show (recursiveLookupTy mappings a) ++ " with " ++ show (recursiveLookupTy mappings b) ++ "\n\n" ++
--show aObj ++ " WITH " ++ show bObj ++ "\n\n" ++
" " ++ pretty aObj ++ " : " ++ showTypeFromXObj aObj ++ "\n " ++ prettyInfoFromXObj aObj ++ "" ++
"\n\nwith \n\n" ++
" " ++ pretty bObj ++ " : " ++ show (recursiveLookupTy mappings b) ++ "\n " ++ prettyInfoFromXObj bObj ++ "\n\n"
" " ++ pretty bObj ++ " : " ++ showTypeFromXObj bObj ++ "\n " ++ prettyInfoFromXObj bObj ++ "\n\n"
-- ++
-- "Constraint: " ++ show constraint ++ "\n\n" ++
-- "All constraints:\n" ++ show constraints ++ "\n\n" ++
-- "Mappings: \n" ++ show mappings ++ "\n\n"
where showTypeFromXObj :: XObj -> String
showTypeFromXObj xobj = case ty xobj of
Just t -> show t
Nothing -> "No type on " ++ show xobj
show (CantDisambiguate xobj originalName theType options) =
"Can't disambiguate symbol '" ++ originalName ++ "' of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++
"\nPossibilities:\n " ++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
show (CantDisambiguateInterfaceLookup xobj name theType options) =
"Can't disambiguate interface lookup symbol '" ++ name ++ "' of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++
"\nPossibilities:\n " ++ joinWith "\n " (map (\(t, p) -> show p ++ " : " ++ show t) options)
show (NoMatchingSignature xobj originalName theType options) =
"Can't find matching lookup for symbol '" ++ originalName ++
"' of type " ++ show theType ++ " at " ++ prettyInfoFromXObj xobj ++

2
test/statistics.carp
View File

@ -6,7 +6,7 @@
(use Statistics)
(defn all-eq [a b]
(if (Double./= (Array.count a) (Array.count b))
(if (Int./= (Array.count a) (Array.count b))
false
(let [res true]
(do