I've written an interesting function in F# which can traverse and map any data structure (much like the everywhere function available in Haskell's Scrap Your Boilerplate). Unfortunately it quickly causes a stack overflow on even fairly small data structures. I was wondering how I can convert it to a tail recursive version, continuation passing style version or an imperative equivalent algorithm. I believe F# supports monads, so the continuation monad is an option.
// These are used for a 50% speedup
let mutable tupleReaders : List<System.Type * (obj -> obj[])> = []
let mutable unionTagReaders : List<System.Type * (obj -> int)> = []
let mutable unionReaders : List<(System.Type * int) * (obj -> obj[])> = []
let mutable unionCaseInfos : List<System.Type * Microsoft.FSharp.Reflection.UnionCaseInfo[]> = []
let mutable recordReaders : List<System.Type * (obj -> obj[])> = []
(*
Traverses any data structure in a preorder traversal
Calls f, g, h, i, j which determine the mapping of the current node being considered
WARNING: Not able to handle option types
At runtime, option None values are represented as null and so you cannot determine their runtime type.
See http://stackoverflow.com/questions/21855356/dynamically-determine-type-of-option-when-it-has-value-none
http://stackoverflow.com/questions/13366647/how-to-generalize-f-option
*)
open Microsoft.FSharp.Reflection
let map5<'a,'b,'c,'d,'e,'z> (f:'a->'a) (g:'b->'b) (h:'c->'c) (i:'d->'d) (j:'e->'e) (src:'z) =
let ft = typeof<'a>
let gt = typeof<'b>
let ht = typeof<'c>
let it = typeof<'d>
let jt = typeof<'e>
let rec drill (o:obj) : obj =
if o = null then
o
else
let ot = o.GetType()
if FSharpType.IsUnion(ot) then
let tag = match List.tryFind (fst >> ot.Equals) unionTagReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeUnionTagReader(ot)
unionTagReaders <- (ot, newReader)::unionTagReaders
newReader o
let info = match List.tryFind (fst >> ot.Equals) unionCaseInfos with
| Some (_, caseInfos) ->
Array.get caseInfos tag
| None ->
let newCaseInfos = FSharpType.GetUnionCases(ot)
unionCaseInfos <- (ot, newCaseInfos)::unionCaseInfos
Array.get newCaseInfos tag
let vals = match List.tryFind (fun ((tau, tag'), _) -> ot.Equals tau && tag = tag') unionReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeUnionReader info
unionReaders <- ((ot, tag), newReader)::unionReaders
newReader o
FSharpValue.MakeUnion(info, Array.map traverse vals)
elif FSharpType.IsTuple(ot) then
let fields = match List.tryFind (fst >> ot.Equals) tupleReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeTupleReader(ot)
tupleReaders <- (ot, newReader)::tupleReaders
newReader o
FSharpValue.MakeTuple(Array.map traverse fields, ot)
elif FSharpType.IsRecord(ot) then
let fields = match List.tryFind (fst >> ot.Equals) recordReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeRecordReader(ot)
recordReaders <- (ot, newReader)::recordReaders
newReader o
FSharpValue.MakeRecord(ot, Array.map traverse fields)
else
o
and traverse (o:obj) =
let parent =
if o = null then
o
else
let ot = o.GetType()
if ft = ot || ot.IsSubclassOf(ft) then
f (o :?> 'a) |> box
elif gt = ot || ot.IsSubclassOf(gt) then
g (o :?> 'b) |> box
elif ht = ot || ot.IsSubclassOf(ht) then
h (o :?> 'c) |> box
elif it = ot || ot.IsSubclassOf(it) then
i (o :?> 'd) |> box
elif jt = ot || ot.IsSubclassOf(jt) then
j (o :?> 'e) |> box
else
o
drill parent
traverse src |> unbox : 'z
Try this (I just used continuation function as parameter):
namespace Solution
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<AutoOpen>]
module Solution =
// These are used for a 50% speedup
let mutable tupleReaders : List<System.Type * (obj -> obj[])> = []
let mutable unionTagReaders : List<System.Type * (obj -> int)> = []
let mutable unionReaders : List<(System.Type * int) * (obj -> obj[])> = []
let mutable unionCaseInfos : List<System.Type * Microsoft.FSharp.Reflection.UnionCaseInfo[]> = []
let mutable recordReaders : List<System.Type * (obj -> obj[])> = []
(*
Traverses any data structure in a preorder traversal
Calls f, g, h, i, j which determine the mapping of the current node being considered
WARNING: Not able to handle option types
At runtime, option None values are represented as null and so you cannot determine their runtime type.
See http://stackoverflow.com/questions/21855356/dynamically-determine-type-of-option-when-it-has-value-none
http://stackoverflow.com/questions/13366647/how-to-generalize-f-option
*)
open Microsoft.FSharp.Reflection
let map5<'a,'b,'c,'d,'e,'z> (f:'a->'a) (g:'b->'b) (h:'c->'c) (i:'d->'d) (j:'e->'e) (src:'z) =
let ft = typeof<'a>
let gt = typeof<'b>
let ht = typeof<'c>
let it = typeof<'d>
let jt = typeof<'e>
let rec drill (o:obj) =
if o = null then
(None, fun _ -> o)
else
let ot = o.GetType()
if FSharpType.IsUnion(ot) then
let tag = match List.tryFind (fst >> ot.Equals) unionTagReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeUnionTagReader(ot)
unionTagReaders <- (ot, newReader)::unionTagReaders
newReader o
let info = match List.tryFind (fst >> ot.Equals) unionCaseInfos with
| Some (_, caseInfos) ->
Array.get caseInfos tag
| None ->
let newCaseInfos = FSharpType.GetUnionCases(ot)
unionCaseInfos <- (ot, newCaseInfos)::unionCaseInfos
Array.get newCaseInfos tag
let vals = match List.tryFind (fun ((tau, tag'), _) -> ot.Equals tau && tag = tag') unionReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeUnionReader info
unionReaders <- ((ot, tag), newReader)::unionReaders
newReader o
// (Some(vals), FSharpValue.MakeUnion(info, Array.map traverse vals))
(Some(vals), (fun x -> FSharpValue.MakeUnion(info, x)))
elif FSharpType.IsTuple(ot) then
let fields = match List.tryFind (fst >> ot.Equals) tupleReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeTupleReader(ot)
tupleReaders <- (ot, newReader)::tupleReaders
newReader o
// (FSharpValue.MakeTuple(Array.map traverse fields, ot)
(Some(fields), (fun x -> FSharpValue.MakeTuple(x, ot)))
elif FSharpType.IsRecord(ot) then
let fields = match List.tryFind (fst >> ot.Equals) recordReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeRecordReader(ot)
recordReaders <- (ot, newReader)::recordReaders
newReader o
// FSharpValue.MakeRecord(ot, Array.map traverse fields)
(Some(fields), (fun x -> FSharpValue.MakeRecord(ot, x)))
else
(None, (fun _ -> o))
and traverse (o:obj) cont =
let parent =
if o = null then
o
else
let ot = o.GetType()
if ft = ot || ot.IsSubclassOf(ft) then
f (o :?> 'a) |> box
elif gt = ot || ot.IsSubclassOf(gt) then
g (o :?> 'b) |> box
elif ht = ot || ot.IsSubclassOf(ht) then
h (o :?> 'c) |> box
elif it = ot || ot.IsSubclassOf(it) then
i (o :?> 'd) |> box
elif jt = ot || ot.IsSubclassOf(jt) then
j (o :?> 'e) |> box
else
o
let child, f = drill parent
match child with
| None ->
f [||] |> cont
| Some(x) ->
match x.Length with
| len when len > 1 ->
let resList = System.Collections.Generic.List<obj>()
let continuation = Array.foldBack (fun t s -> (fun mC -> resList.Add(mC); traverse t s) )
(x.[1..])
(fun mC -> resList.Add(mC); resList.ToArray() |> f |> cont)
traverse (x.[0]) continuation
| _ -> traverse x (fun mC ->
match mC with
| :? (obj[]) as mC -> f mC |> cont
| _ -> f [|mC|] |> cont
)
traverse src (fun x -> x) |> unbox : 'z
You should build this with enabled Generate tail calls option (by default, this option disabled in Debug mode, but enabled in Release).
Example:
type A1 =
| A of A2
| B of int
and A2 =
| A of A1
| B of int
and Root =
| A1 of A1
| A2 of A2
[<EntryPoint>]
let main args =
let rec build (elem: Root) n =
if n = 0 then elem
else
match elem with
| A1(x) -> build (Root.A2(A2.A(x))) (n-1)
| A2(x) -> build (Root.A1(A1.A(x))) (n-1)
let tree = build (Root.A1(A1.B(2))) 100000
let a = map5 (fun x -> x) (fun x -> x) (fun x -> x) (fun x -> x) (fun x -> x) tree
printf "%A" a
0
This code finished without Stack Overflow exception.
I ended up converting the code to an imperative style to avoid the Stack Overflow:
open Microsoft.FSharp.Reflection
let mutable tupleReaders : List<System.Type * (obj -> obj[])> = []
let mutable unionTagReaders : List<System.Type * (obj -> int)> = []
let mutable unionReaders : List<(System.Type * int) * (obj -> obj[])> = []
let mutable unionCaseInfos : List<System.Type * Microsoft.FSharp.Reflection.UnionCaseInfo[]> = []
let mutable recordReaders : List<System.Type * (obj -> obj[])> = []
type StructureInfo = Union of UnionCaseInfo
| Tuple of System.Type
| Record of System.Type
| Leaf
let map5<'a,'b,'c,'d,'e,'z> (f:'a->'a) (g:'b->'b) (h:'c->'c) (i:'d->'d) (j:'e->'e) (src:'z) : 'z =
let ft = typeof<'a>
let gt = typeof<'b>
let ht = typeof<'c>
let it = typeof<'d>
let jt = typeof<'e>
let getStructureInfo (o : obj) =
if o = null then
(Leaf, [||])
else
let ot = o.GetType()
if FSharpType.IsUnion(ot) then
let tag = match List.tryFind (fst >> ot.Equals) unionTagReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeUnionTagReader(ot)
unionTagReaders <- (ot, newReader)::unionTagReaders
newReader o
let info = match List.tryFind (fst >> ot.Equals) unionCaseInfos with
| Some (_, caseInfos) ->
Array.get caseInfos tag
| None ->
let newCaseInfos = FSharpType.GetUnionCases(ot)
unionCaseInfos <- (ot, newCaseInfos)::unionCaseInfos
Array.get newCaseInfos tag
let children =
match List.tryFind (fun ((tau, tag'), _) -> ot.Equals tau && tag = tag') unionReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeUnionReader info
unionReaders <- ((ot, tag), newReader)::unionReaders
newReader o
(Union info, children)
elif FSharpType.IsTuple(ot) then
let children =
match List.tryFind (fst >> ot.Equals) tupleReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeTupleReader(ot)
tupleReaders <- (ot, newReader)::tupleReaders
newReader o
(Tuple ot, children)
elif FSharpType.IsRecord(ot) then
let children =
match List.tryFind (fst >> ot.Equals) recordReaders with
| Some (_, reader) ->
reader o
| None ->
let newReader = FSharpValue.PreComputeRecordReader(ot)
recordReaders <- (ot, newReader)::recordReaders
newReader o
(Record ot, children)
else
(Leaf, [||])
let root = src |> box |> ref
let mutable nodes = [root]
let mutable completedNodes = []
while not (List.isEmpty nodes) do
let node = List.head nodes
nodes <- List.tail nodes
let o = !node
let o' = if o = null then
o
else
let ot = o.GetType()
if ft = ot || ot.IsSubclassOf(ft) then
f (o :?> 'a) |> box
elif gt = ot || ot.IsSubclassOf(gt) then
g (o :?> 'b) |> box
elif ht = ot || ot.IsSubclassOf(ht) then
h (o :?> 'c) |> box
elif it = ot || ot.IsSubclassOf(it) then
i (o :?> 'd) |> box
elif jt = ot || ot.IsSubclassOf(jt) then
j (o :?> 'e) |> box
else
o
node := o'
let (structure, children) = getStructureInfo o'
let childrenContainers = children |> Array.map ref
completedNodes <- (node, structure, childrenContainers)::completedNodes
nodes <- List.append (List.ofArray childrenContainers) nodes
completedNodes |> List.iter
(fun (oContainer, structureInfo, childrenContainers) ->
let children = Array.map (!) childrenContainers
match structureInfo with
| Union info ->
oContainer := FSharpValue.MakeUnion(info, children)
| Tuple ot ->
oContainer := FSharpValue.MakeTuple(children, ot)
| Record ot ->
oContainer := FSharpValue.MakeRecord(ot, children)
| Leaf -> ())
(unbox !root) : 'z
Related
How to allow a function to accept a generic list of functions?
I have the code below, but the compiler is rejecting the line where I try to set partiallyAppliedAdds, with the error:
Type mismatch. Expecting a int -> int' given a int -> 'a -> 'b'
type ApplicativeFunctor(fnList: 'a list) =
member private this.fnList: 'a list = fnList
member this.ap (apTarget: int list) = ([], this.fnList) ||> List.fold (fun (acc: 'a list) fn -> acc # (apTarget |> List.map fn))
let add1 a = a + 1
ApplicativeFunctor([add1]).ap([1]) // [2]
let arg1 = [1; 3]
let add x = fun y -> x + y
let partiallyAppliedAdds = ApplicativeFunctor[add].ap(arg1) // Type mismatch. Expecting a int -> int' given a int -> 'a -> 'b'
Is this easily accomplishable in F#, or should I approach this differently?
To fix your version, you do:
type ApplicativeFunctor<'a,'b>(fnList: list<'a -> 'b>) =
member private _.fnList = fnList
member this.ap apTarget =
([], this.fnList)
||> List.fold (fun acc fn -> acc # List.map fn apTarget)
let add1 a = a + 1
let res1 = ApplicativeFunctor([add1]).ap([1]) (* [2] *)
printfn "%A" res1
let paAdd = ApplicativeFunctor[fun x y -> x + y].ap([1;3])
printfn "%A" paAdd
But the general approach is just
let ap fs xs =
List.foldBack2 (fun f x state ->
f x :: state
) fs xs []
let add x y z = x + y + z
let xs = [1..3]
let ys = [10;20;30]
let zs = [100;200;300]
let res1 = (ap (ap (List.map add xs) ys) zs)
printfn "%A" res1 (* [111;222;333] *)
(* Custom operators *)
let (<!>) = List.map
let (<*>) = ap
let res2 = add <!> xs <*> ys <*> zs
printfn "%A" res2 (* [111;222;333] *)
I would like to extend the W algorithm to the inference of tuples and lists in F#, a priori, there are only two rules to add, which I did, however, the result is partially bad.
Indeed, if I test a code like these:
test = (8, "Hello", 0.3) -- test :: (TInt, TString, TFloat)
id :: a -> a
id x = x -- id :: a -> a
foo = id 8 -- foo :: TInt
it works, on the other hand, as detailed in the examples below, a code like this one will not work:
makePair = (\x -> (x, x)) -- makePair :: a -> (a, a)
pair = makePair 7
and pair will be inferred as (a, a) instead of (TInt, TInt).
Same for the lists.
I used this paper to write my type checker.
I really don't understand what's jamming.
Here is the minimum functional program used for these examples:
Inference.fs
module Typechecker
type Identifier = string
and Expr =
| Var of Identifier
| Lambda of Identifier * Expr
| Apply of Expr * Expr
| Let of Identifier * Expr * Expr
| Literal of Literal
| Tuple of Expr list
| List of Expr list
and Literal =
| Int of int
| Float of float
| String of string
and Statement =
| Signature of Identifier * Type
| Declaration of Identifier * Expr
and Type =
| TVar of Identifier
| TInt
| TFloat
| TString
| TArrow of Type * Type
| TTuple of Type list
| TList of Type
type Program = Program of Statement list
type Scheme = Scheme of string list * Type
and TypeEnv = Map<Identifier, Scheme>
and Subst = Map<string, Type>
type Env =
{ mutable _functions: Function list }
with
member this.containsFunction name =
this._functions |> List.exists (fun f -> f._name = name)
member this.getFunction name =
this._functions
|> List.find (fun (f: Function) -> f._name = name)
member this.getFunctionType name =
(this.getFunction name)._type
member this.hasFunctionImplementation name =
if this.containsFunction name
then (this.getFunction name)._value.IsSome
else false
member this.getFunctionValue name =
(this.getFunction name)._value.Value
/// Updates the value of a function in the environment
member this.updateFunction_value name value =
(this.getFunction name)._value <- Some value
this
/// Updates the type of a function in the environment
member this.updateFunction_type name ty =
(this.getFunction name)._type <- ty
this
member this.addFunction name ty value =
{ _functions =
List.append
this._functions
[{ _name = name;
_type = ty;
_value = value }] }
and Function =
{ _name: Identifier;
mutable _type: Type;
mutable _value: Expr option }
and DataType =
{ _name: Identifier;
_isAlias: bool;
_constructors: Ctor list option
_alias: Type option }
and Ctor = Term of Identifier | Product of Type list
let newEnv = { _functions = [] }
module Type =
let rec ftv = function
| TInt -> Set.empty
| TFloat -> Set.empty
| TString -> Set.empty
| TVar name -> Set.singleton name
| TArrow(t1, t2) -> Set.union (ftv t1) (ftv t2)
| TTuple ts -> List.fold (fun acc t -> Set.union acc (ftv t)) Set.empty ts
| TList t -> Set.singleton (toString t)
and apply s t =
match t with
| TVar name ->
match Map.tryFind name s with
| Some t -> t
| None -> TVar name
| TArrow (t1, t2) ->
TArrow(apply s t1, apply s t2)
| TInt | TFloat | TString -> t
| _ -> t
and parens s =
sprintf "(%s)" s
and braces s =
sprintf "{ %s }" s
and toString t =
let rec parenType t' =
match t' with
| TArrow(_, _) -> parens (toString t')
| _ -> toString t'
match t with
| TVar name -> name
| TInt -> "Integer"
| TFloat -> "Float"
| TString -> "String"
| TArrow(t1, t2) ->
(parenType t1) + " -> " + (toString t2)
| TTuple ts -> sprintf "(%s)" (System.String.Join(", ", List.map toString ts))
| TList t -> sprintf "[%s]" (toString t)
module Scheme =
let rec ftv (scheme: Scheme) =
match scheme with
| Scheme(variables, t) ->
Set.difference(Type.ftv t) (Set.ofList variables)
and apply (s: Subst) (scheme: Scheme) =
match scheme with
| Scheme(variables, t) ->
let newSubst = List.foldBack (fun key currentSubst -> Map.remove key currentSubst) variables s
let newType = Type.apply newSubst t
Scheme(variables, newType)
module TypeEnv =
let rec remove (env: TypeEnv) (var: Identifier) =
Map.remove var env
and ftv (typeEnv: TypeEnv) =
Seq.foldBack (fun (KeyValue(_, v)) state ->
Set.union state (Scheme.ftv v)) typeEnv Set.empty
and apply (s: Subst) (env: TypeEnv) =
Map.map (fun _ value -> Scheme.apply s value) env
module Subst =
let compose s1 s2 =
Map.union (Map.map (fun _ (v: Type) -> Type.apply s1 v) s2) s1
let rec generalize (env: TypeEnv) (t: Type) =
let variables =
Set.difference (Type.ftv t) (TypeEnv.ftv env)
|> Seq.toList
Scheme(variables, t)
and private currentId = ref 'a'
and nextId () =
let id = !currentId
currentId := (char ((int !currentId) + 1))
id
and resetId () = currentId := 'a'
and newTyVar () =
TVar(sprintf "%c" (nextId ()))
and instantiate (ts: Scheme) =
match ts with
| Scheme(variables, t) ->
let nvars = variables |> List.map (fun name -> newTyVar ())
let s = List.zip variables nvars |> Map.ofList
Type.apply s t
and varBind a t =
match t with
| TVar name when name = a -> Map.empty
| _ when Set.contains a (Type.ftv t) ->
failwithf "Occur check fails: `%s` vs `%s`" a (Type.toString t)
| _ -> Map.singleton a t
and unify (t1: Type) (t2: Type) : Subst =
match t1, t2 with
| TVar a, t | t, TVar a -> varBind a t
| TInt, TInt -> Map.empty
| TFloat, TFloat -> Map.empty
| TString, TString -> Map.empty
| TArrow(l, r), TArrow(l', r') ->
let s1 = unify l l'
let s2 = unify (Type.apply s1 r) (Type.apply s1 r')
Subst.compose s2 s1
| TTuple ts, TTuple ts' ->
if ts.Length <> ts'.Length
then failwithf "Types do not unify: `%s` vs `%s`" (Type.toString t1) (Type.toString t2)
else List.fold Subst.compose Map.empty (List.map2 unify ts ts')
| TList t, TList t' ->
unify t t'
| _ -> failwithf "Types do not unify: `%s` vs `%s`" (Type.toString t1) (Type.toString t2)
and tiLit = function
| Literal.Int _ -> Type.TInt
| Literal.Float _ -> Type.TFloat
| Literal.String _ -> Type.TString
and tiExpr (env: TypeEnv) (exp: Expr) : Subst * Type =
match exp with
| Var name ->
match Map.tryFind name env with
| Some sigma ->
let t = instantiate sigma
(Map.empty, t)
| None -> failwithf "Unbound variable: `%s`" name
| Literal lit -> (Map.empty, tiLit lit)
| Let(id, expr, in') ->
let s1, t1 = tiExpr env expr
let env1 = TypeEnv.remove env id
let scheme = generalize (TypeEnv.apply s1 env) t1
let env2 = Map.add id scheme env1
let s2, t2 = tiExpr (TypeEnv.apply s1 env2) in'
(Subst.compose s2 s1, t2)
| Lambda(id, value) ->
let tv = newTyVar ()
let env1 = TypeEnv.remove env id
let env2 = Map.union env1 (Map.singleton id (Scheme([], tv)))
let s1, t1 = tiExpr env2 value
(s1, TArrow(Type.apply s1 tv, t1))
| Tuple values ->
(Map.empty, TTuple(List.map (fun v -> snd (tiExpr env v)) values))
| List ts ->
let tv = newTyVar ()
if ts.IsEmpty
then (Map.empty, TList tv)
else
let _, t1 = tiExpr env ts.[0]
if List.forall (fun t -> snd (tiExpr env t) = t1) ts
then (Map.empty, TList t1)
else failwith "Not all items in the list are of the same type"
| Apply(e1, e2) ->
let s1, t1 = tiExpr env e1
let s2, t2 = tiExpr (TypeEnv.apply s1 env) e2
let tv = newTyVar ()
let s3 = unify (Type.apply s2 t1) (TArrow(t2, tv))
(Subst.compose (Subst.compose s3 s2) s1, Type.apply s3 tv)
and expression_typeInference env exp =
let s, t = tiExpr env exp
Type.apply s t
and updateExprEnv (env: Env) =
let mutable env' = Map.empty
List.iter
(fun (f: Function) ->
env' <- env'.Add(f._name, Scheme([f._name], f._type))
) env._functions
env'
let rec public statement_typecheck (env: Env) stmt =
let exprEnv = updateExprEnv env
match stmt with
| Signature(id, dastType) ->
typecheck_signature env id dastType
| Declaration(id, value) ->
typecheck_decl env id value exprEnv
and private typecheck_signature (env: Env) id ty =
if env.hasFunctionImplementation id
then failwithf "The type of a function cannot be defined after its implementation (`%s`)" id
else env.addFunction id ty None
and private typecheck_decl (env: Env) id value exprEnv =
let _, t_exp = tiExpr exprEnv value
if env.containsFunction id
then if env.hasFunctionImplementation id
then failwithf "Already declared function: `%s`" id
else
let t_sgn = (env.getFunction id)._type
let unapp = try (Type.apply ((unify t_sgn t_exp)) t_exp)
|> Ok with exn -> failwithf "%s" exn.Message
if match unapp with Result.Ok _ -> true
then env.updateFunction_value id value
else failwithf "The signature of `%s` is different than the type of its value\n (`%s` vs `%s`)"
id (Type.toString t_sgn) (Type.toString t_exp)
else env.addFunction id t_exp (Some value)
let typecheck_document (document: Program) =
let mutable docenv = newEnv
match document with Program stmts ->
List.iter (fun stmt -> docenv <- statement_typecheck docenv stmt) stmts
docenv
Main.fs
module Main
open Inference
[<EntryPoint>]
let main _ =
let test1 =
[Declaration("makePair", Lambda("x", Tuple([Var "x"; Var "x"]))); // makePair = (\x -> (x, x))
Declaration("pair", Apply(Var "makePair", Literal (Int 7)))] // pair = makePair 7
let infer1 = typecheck_document (Program test1)
printfn "Env1: %A" infer1
let test2 =
[Signature("id", TArrow(TVar "a", TVar "a")); // id :: a -> a
Declaration("id", Lambda("x", Var "x")) // id x = x
Declaration("foo", Apply(Var "id", Literal (Int 7)))] // foo = id 7
let infer2 = typecheck_document (Program test2)
printfn "Env2: %A" infer2
0
Here is the output:
Env1: {_functions =
[{_name = "makePair";
_type = TArrow (TVar "a",TTuple [TVar "a"; TVar "a"]);
_value = Some (Lambda ("x",Tuple [Var "x"; Var "x"]));};
{_name = "pair";
_type = TTuple [TVar "a"; TVar "a"];
_value = Some (Apply (Var "makePair",Literal (Int 7)));}];}
Env2: {_functions =
[{_name = "id";
_type = TArrow (TVar "a",TVar "a");
_value = Some (Lambda ("x",Var "x"));};
{_name = "test";
_type = TInt;
_value = Some (Apply (Var "id",Literal (Int 7)));}];}
So we can see that the inference works correctly for the first test, but not for the second (as shown above).
I would like to solve and understand this bug, and I thank you in advance for your help.
As far as I read in your code, it seems like you're missing a branch in apply.
Indeed, when t is a Tuple [], you're basically only returning it...which well will of course not work. :)
I suggest adding one branch to the match, with t as a Tuple types, with a map (\t -> apply s t) types (sorry, I don't know much F# syntax).
Hope it helps. :)
Given the following types
type IDocPartX<'delta, 'pures> =
abstract member ToDelta: 'pures -> 'delta
abstract member ToPure: 'delta -> 'pures
abstract member Validate: 'pures -> Option<'pures>
type InitX<'a>(v:'a) =
member this.Value = v
type Foo<'a> = {value: 'a} with
interface IDocPartX<Foo<int>, Foo<string>> with
member this.ToDelta x = Unchecked.defaultof<_>
member this.ToPure x = Unchecked.defaultof<_>
member this.Validate x = Unchecked.defaultof<_>
this function
let inline ValidateInitX(x:InitX<IDocPartX<'d,'p>>) =
let r = x.Value
let d = r :?> 'd
let o =
d
|> r.ToPure
|> r.Validate
match o with
| Some v -> r.ToDelta v |> Init |> Some
| _ -> None
and this values
let a = InitX {value = 1}
let b = ValidateInitX a
why is the value a not recognized to be of InitX<IDocPartX<'a, 'b>>?
OK, a bit of SRTPs magic on the function definition will do the trick
let inline ValidateInitX<'d, 'p when 'd :> IDocPartX<'d,'p>>(x:InitX<'d>) =
let r = x.Value
let o =
r
|> r.ToPure
|> r.Validate
match o with
| Some v -> r.ToDelta v |> Init |> Some
| _ -> None
I am talking about the zip operations in the context of heterogeneous lists. I am working on a lightly dependently typed language that uses them as tuples.
type T =
| S of string
| R of T list
let rec zip l =
let is_all_r_empty x = List.forall (function R [] -> true | _ -> false) x
let rec loop acc_total acc_head acc_tail x =
match x with
| S _ :: _ -> R l
| R [] :: ys ->
if List.isEmpty acc_head && is_all_r_empty ys then List.rev acc_total |> R
else R l
| R (x :: xs) :: ys -> loop acc_total (x :: acc_head) (R xs :: acc_tail) ys
| [] ->
match acc_tail with
| _ :: _ -> loop ((List.rev acc_head |> zip) :: acc_total) [] [] (List.rev acc_tail)
| _ -> List.rev acc_total |> R
loop [] [] [] l
let rec unzip l =
let transpose l =
let is_all_empty x = List.forall (function _ :: _ -> false | _ -> true) x
let rec loop acc_total acc_head acc_tail = function
| (x :: xs) :: ys -> loop acc_total (x :: acc_head) (xs :: acc_tail) ys
| [] :: ys ->
if List.isEmpty acc_head && is_all_empty ys then loop acc_total acc_head acc_tail ys
else l
| [] ->
match acc_tail with
| _ :: _ -> loop (List.rev acc_head :: acc_total) [] [] (List.rev acc_tail)
| _ -> List.rev acc_total
loop [] [] [] l
let is_all_r x = List.forall (function R _ -> true | _ -> false) x
match l with
| R x when is_all_r x -> List.map unzip x |> transpose |> List.map R
| R x -> x
| S _ -> failwith "Unzip called on S."
//let a = R [R [S "a"; S "t"]; R [S "b"; S "w"]; R [S "c"; S "e"]]
//let b = R [R [S "1"; S "4"]; R [S "5"; S "r"]; R [S "3"; S "6"]]
//let c = R [R [S "z"; S "v"]; R [S "x"; S "b"]; R [S "c"; S "2"]]
//
//let t3 = zip [a;b]
//let t4 = zip [t3;c]
//let u1 = unzip t4
//let r1 = u1 = [t3;c]
//let u2 = unzip t3
//let r2 = u2 = [a;b] // The above works fine on tuples with regular dimensions.
let a = R [R [S "q"; S "w"; S "e"]]
let b = R [R [S "a"; S "s"]; R [S "z"]; S "wqe"]
let ab = [a;b]
let t = zip ab
let t' = unzip t
ab = t' // This is false, but I would like the ziping and then unziping to be reversible if possible.
Zipping and unzipping in general can be expressed as a dimensional shift or a series of transposes. That is all these two functions are doing.
They behave well on regular tuples, but I would like zip+unzip to be isomorphic on irregular ones as well. My intuition is telling me that this would be asking too much of them though.
I need a second opinion here.
#r "../../packages/FsCheck.2.8.0/lib/net452/FsCheck.dll"
type T =
| S of string
| VV of T list
let transpose l on_fail on_succ =
let is_all_vv_empty x = List.forall (function VV [] -> true | _ -> false) x
let rec loop acc_total acc_head acc_tail = function
| VV [] :: ys ->
if List.isEmpty acc_head && is_all_vv_empty ys then
if List.isEmpty acc_total then failwith "Empty inputs in the inner dimension to transpose are invalid."
else List.rev acc_total |> on_succ
else on_fail ()
| VV (x :: xs) :: ys -> loop acc_total (x :: acc_head) (VV xs :: acc_tail) ys
| _ :: _ -> on_fail ()
| [] ->
match acc_tail with
| _ :: _ -> loop (VV (List.rev acc_head) :: acc_total) [] [] (List.rev acc_tail)
| _ -> List.rev acc_total |> on_succ
loop [] [] [] l
let rec zip l =
match l with
| _ :: _ -> transpose l (fun _ -> l) (List.map (function VV x -> zip x | x -> x)) |> VV
| _ -> failwith "Empty input to zip is invalid."
let rec unzip l =
let is_all_vv x = List.forall (function VV _ -> true | _ -> false) x
match l with
| VV x ->
match x with
| _ :: _ when is_all_vv x -> let t = List.map (unzip >> VV) x in transpose t (fun _ -> x) id
| _ :: _ -> x
| _ -> failwith "Empty inputs to unzip are invalid."
| S _ -> failwith "Unzip called on S."
open FsCheck
open System
let gen_t =
let mutable gen_t = None
let gen_s () = Gen.map S Arb.generate<string>
let gen_vv size = Gen.nonEmptyListOf (gen_t.Value size) |> Gen.map VV
gen_t <-
fun size ->
match size with
| 0 -> gen_s()
| _ when size > 0 -> Gen.oneof [gen_s (); gen_vv (size-1)]
| _ -> failwith "impossible"
|> Some
gen_t.Value
|> Gen.sized
let gen_t_list_irregular = Gen.nonEmptyListOf gen_t
let gen_t_list_regular = Gen.map2 List.replicate (Gen.choose(1,10)) gen_t
type MyGenerators =
static member Tuple() = Arb.fromGen gen_t
static member TupleList() = Arb.fromGen gen_t_list_regular
Arb.register<MyGenerators>()
let zip_and_unzip orig = zip orig |> unzip
let zip_and_unzip_eq_orig orig = zip_and_unzip orig = orig
// For regular tuples it passes with flying colors.
Check.One ({Config.Quick with EndSize = 10}, zip_and_unzip_eq_orig)
// I can't get it to be isomorphic for irregularly sized arrays as expected.
//let f x =
// let x' = zip x
// printfn "x'=%A" x'
// printfn "unzip x'=%A" (unzip x')
// printfn "zip_and_unzip_eq_orig x=%A" (zip_and_unzip_eq_orig x)
//
//f [VV [VV [S "12"; S "qwe"]; VV [S "d"]]; VV [VV [S ""; S "ug"]; VV [S ""]]]
No matter what, I try I cannot figure out how to make the pair isomorphic for irregularly sized tuples and I feel it is unlikely that anyone will tell me differently so I'll put the above attempt as an answer for now.
On the upside, based on the tests above, I am decently sure that it should be isomorphic for all regularly sizes tuples. I guess this should suffice. I've tightened the code up a little compared to the example I had in the question.
This irregular zipping and unzipping problem would make an interesting math puzzle.
I need to extract the sequence of equal chars in a text.
For example:
The string "aaaBbbcccccccDaBBBzcc11211" should be converted to a list of strings like
["aaa";"B";"bb";"ccccccc";"D";"a";"BBB";"z";"cc";"11";"2";"11"].
That's my solution until now:
let groupSequences (text:string) =
let toString chars =
System.String(chars |> Array.ofList)
let rec groupSequencesRecursive acc chars = seq {
match (acc, chars) with
| [], c :: rest ->
yield! groupSequencesRecursive [c] rest
| _, c :: rest when acc.[0] <> c ->
yield (toString acc)
yield! groupSequencesRecursive [c] rest
| _, c :: rest when acc.[0] = c ->
yield! groupSequencesRecursive (c :: acc) rest
| _, [] ->
yield (toString acc)
| _ ->
yield ""
}
text
|> List.ofSeq
|> groupSequencesRecursive []
groupSequences "aaaBbbcccccccDaBBBzcc11211"
|> Seq.iter (fun x -> printfn "%s" x)
|> ignore
I'm a F# newbie.
This solution can be better?
Here a completely generic implementation:
let group xs =
let folder x = function
| [] -> [[x]]
| (h::t)::ta when h = x -> (x::h::t)::ta
| acc -> [x]::acc
Seq.foldBack folder xs []
This function has the type seq<'a> -> 'a list list when 'a : equality, so works not only on strings, but on any (finite) sequence of elements, as long as the element type supports equality comparison.
Used with the input string in the OP, the return value isn't quite in the expected shape:
> group "aaaBbbcccccccDaBBBzcc11211";;
val it : char list list =
[['a'; 'a'; 'a']; ['B']; ['b'; 'b']; ['c'; 'c'; 'c'; 'c'; 'c'; 'c'; 'c'];
['D']; ['a']; ['B'; 'B'; 'B']; ['z']; ['c'; 'c']; ['1'; '1']; ['2'];
['1'; '1']]
Instead of a string list, the return value is a char list list. You can easily convert it to a list of strings using a map:
> group "aaaBbbcccccccDaBBBzcc11211" |> List.map (List.toArray >> System.String);;
val it : System.String list =
["aaa"; "B"; "bb"; "ccccccc"; "D"; "a"; "BBB"; "z"; "cc"; "11"; "2"; "11"]
This takes advantage of the String constructor overload that takes a char[] as input.
As initially stated, this implementation is generic, so can also be used with other types of lists; e.g. integers:
> group [1;1;2;2;2;3;4;4;3;3;3;0];;
val it : int list list = [[1; 1]; [2; 2; 2]; [3]; [4; 4]; [3; 3; 3]; [0]]
How about with groupby
"aaaBbbcccccccD"
|> Seq.groupBy id
|> Seq.map (snd >> Seq.toArray)
|> Seq.map (fun t -> new string (t))
If you input order matters, here is a method that works
"aaaBbbcccccccDaBBBzcc11211"
|> Seq.pairwise
|> Seq.toArray
|> Array.rev
|> Array.fold (fun (accum::tail) (ca,cb) -> if ca=cb then System.String.Concat(accum,string ca)::tail else string(ca)::accum::tail) (""::[])
This one is also based on recursion though the matching gets away with smaller number of checks.
let chop (txt:string) =
let rec chopInner txtArr (word: char[]) (res: List<string>) =
match txtArr with
| h::t when word.[0] = h -> chopInner t (Array.append word [|h|]) res
| h::t when word.[0] <> h ->
let newWord = word |> (fun s -> System.String s)
chopInner t [|h|] (List.append res [newWord])
| [] ->
let newWord = word |> (fun s -> System.String s)
(List.append res [newWord])
let lst = txt.ToCharArray() |> Array.toList
chopInner lst.Tail [|lst.Head|] []
And the result is as expected:
val text : string = "aaaBbbcccccccDaBBBzcc11211"
> chop text;;
val it : string list =
["aaa"; "B"; "bb"; "ccccccc"; "D"; "a"; "BBB"; "z"; "cc"; "11"; "2"; "11"]
When you're folding, you'll need to carry along both the previous value and the accumulator holding the temporary results. The previous value is wrapped as option to account for the first iteration. Afterwards, the final result is extracted and reversed.
"aaaBbbcccccccDaBBBzcc11211"
|> Seq.map string
|> Seq.fold (fun state ca ->
Some ca,
match state with
| Some cb, x::xs when ca = cb -> x + ca::xs
| _, xss -> ca::xss )
(None, [])
|> snd
|> List.rev
// val it : string list =
// ["aaa"; "B"; "bb"; "ccccccc"; "D"; "a"; "BBB"; "z"; "cc"; "11"; "2"; "11"]
Just interesting why everyone publishing solutions based on match-with? Why not go plain recursion?
let rec groups i (s:string) =
let rec next j = if j = s.Length || s.[i] <> s.[j] then j else next(j+1)
if i = s.Length then []
else let j = next i in s.Substring(i, j - i) :: (groups j s)
"aaaBbbcccccccDaBBBzcc11211" |> groups 0
val it : string list = ["aaa"; "B"; "bb"; "ccccccc"; "D"; "a"; "BBB"; "z"; "cc"; "11"; "2"; "11"]
As someone other here:
Know thy fold ;-)
let someString = "aaaBbbcccccccDaBBBzcc11211"
let addLists state elem =
let (p, ls) = state
elem,
match p = elem, ls with
| _, [] -> [ elem.ToString() ]
| true, h :: t -> (elem.ToString() + h) :: t
| false, h :: t -> elem.ToString() :: ls
someString
|> Seq.fold addLists ((char)0, [])
|> snd
|> List.rev